指定フォルダ配下の画像貼り付け

画像ファイルが入っているフォルダを指定して、そのフォルダの中の画像ファイルをexcelシートに貼り付けるプログラムを作成しました。画像ファイルの貼り付けはActiveSheet.Pictures.Insert(ファイルパス)メソッドで行います。このメソッドは画像をアクティブセルに貼り付けするとともに画像のオブジェクトを戻り値としてかえしてくれます。オブジェクトからサイズの指定なども行うことができます。これを利用し、画像サイズは上限を設定し、上限を超える場合は上限値に設定することができます。プログラムの全体的な流れはファイルパスを取得→アクティブセルに画像を貼り付ける→画像のサイズを変更する→アクティブセルを次の画像がはれる位置へ移動(画像が重ならないようにするため)になります。画像のファイルパスの取得はいつものようにA1セルから取得しません。見栄えがあまりよくないことと入力ミスのエラー処理を書かなければいけないことが理由です。そこで、ダイアログボックスでフォルダを選択できるようにしました。これならばセルへの入力は行わず、常に存在するフォルダが選択できるためエラー処理がいりません。

貼り付ける画像の種類ですが、拡張子が、「jpg」、「.jpeg」、「.bmp」のものに固定しました。注意事項として、画像をあまり多くはらないようにするこです。多く張りすぎると、ファイルを保存する時に時間がかかってしまいます。

Option Explicit

'画像の最大高さを設定
Public Const maxHeight As Integer = 50

Public Sub PicIns()
        
    'Shellオブジェクト生成
    Dim objShell As shell
    Set objShell = CreateObject("Shell.Application")
    
    '選択されたフォルダのFolderオブジェクト(FileSystemObjectのFolderとは異なる)を取得
    'BrowseForFolderの第一引数：ウィンドウのハンドル(0なら問題ないようです)
    'BrowseForFolderの第二引数：ダイアログに表示させる説明文
    'BrowseForFolderの第三引数：ダイアログのタイプ(&H1はファイルシステムのフォルダのみ選択可能)
    'BrowseForFolderの第三引数：ルートフォルダのパス(省略)
    Dim objFol As Folder
    Set objFol = objShell.BrowseForFolder(0, "画像が格納されているフォルダを選択してください。", &H1)
    
    'キャンセルの場合(戻り値がNULL)、終了
    If objFol Is Nothing Then
        Set objFol = Nothing      'Folderオブジェクトの解放
        Set objShell = Nothing    'Shellオブジェクトの解放
        MsgBox "キャンセルしました。"
        Exit Sub
    End If
    
    Cells(2, "A").Activate 'A2セルを選択する
    
    'フォルダ内のファイル数分ループ
    Dim i As Integer
    Dim pic As Object
    For i = 0 To objFol.Items.Count - 1
        '拡張子が「.jpg」、「.jpeg」、「.bmp」の場合
        If LCase(Right(objFol.Items.Item(i).Name, 4)) = ".jpg" Or _
            LCase(Right(objFol.Items.Item(i).Name, 5)) = ".jpeg" Or _
            LCase(Right(objFol.Items.Item(i).Name, 4)) = ".bmp" Then
        
            'アクティブセルの1行前にファイル名を表示
            ActiveCell.Offset(-1, 0).Value = "[" & objFol.Items.Item(i).Name & "]"
            '画像貼り付け(戻り値は貼り付けたオブジェクトになります)
            Set pic = ActiveSheet.Pictures.Insert(objFol.Items.Item(i).Path)
            
            '画像サイズが最大高さより大きかった場合は最大高さに設定する
            If pic.ShapeRange.Height > maxHeight Then
                pic.ShapeRange.Height = maxHeight
            End If
            
            '画像サイズより画像を貼り付けてから移動したセルのサイズのほうが大きい場合抜ける
            Dim aHeight As Integer
            aHeight = ActiveCell.Height '1行目のサイズを取得
            Do While pic.ShapeRange.Height > aHeight
                ActiveCell.Offset(1, 0).Activate    '下の行をアクティブにする
                aHeight = aHeight + ActiveCell.Height   '1行サイズを加算
            Loop
            
            Set pic = Nothing   'ピクチャオブジェクトの解放
            
            '3行間隔をあける
            ActiveCell.Offset(3, 0).Activate
        End If
    Next
    Set objFol = Nothing      'Folderオブジェクトの解放
    Set objShell = Nothing    'Shellオブジェクトの解放
    
    MsgBox "完了しました。"

End Sub