VBA サブフォルダ内の全ての画像ファイルをExcelに貼り付ける

'18/05/19更新：フォルダ名／ファイル名の並びを各々ソートして取得する仕様にコードを更新した。
本プログラムは、main関数を指定して実行するとダイアログが表示されるので、下図のように画像ファイルがあるサブフォルダの親フォルダの箇所でOKを押す。ちなみに、画像ファイルの取得方法には拡張子.jpgを指定しているため、各フォルダ内に画像ファイル以外のファイルが存在しても動作に支障はない。

すると、下図のように「画像一覧」シートの１行目にサブフォルダ名を記載し、それら各列に各サブフォルダ内の画像が貼り付けられる。ちなみに、F列のPCcase_geforceは空なのは、フォルダ内に画像がないためである。

また、下図のように「ファイル名一覧」のシートに取得したファイル名を記載する仕様である。

▼本プログラム（'18/05/19更新）

あらかじめ、Excelシート「画像一覧」と「ファイル名一覧」を作成する(上図の左下のように）。これは、画像貼り付けやファイル名などを書き込むシート名をコード内で指定しているためである。そして、実行にはmain関数を指定してマクロ実行すれば良い。ちなみに、画像のアスペクト比を保ちたければ、.LockAspectRatio = False箇所のFalseをTrueにすれば良い。

Option Explicit '変数を必ず宣言する意
'ソートのためのAPI読み出し宣言
Declare PtrSafe Function StrCmpLogicalW Lib "SHLWAPI.DLL" _
(ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
'空配列の判定のためのAPI読み出し宣言
Declare Function SafeArrayGetDim Lib "oleaut32" _
(ByRef psa() As Any) As Long
'Publicはローカル変数でなく、グローバル変数の意味
'他のモジュールでも使用できる。例えばフォームモジュール等
Public myfolder As String
Public mySubfld(), myfname() As Variant
Public myfileNmax As Integer
Public セル行の高さ, セル列の幅, 表のフォント As Long

Sub main()　'main関数：フォームに登録する場合はここを指定する。
    Dim n, cnt, i, j As Integer
    
    ' =====パラメータ=====
    セル行の高さ = 85
    セル列の幅 = 17.5
    表のフォント = 10
    '=====================
    
    Application.ScreenUpdating = False
    
    ' 初期化（すでに貼り付けられてる画像ファイルなどの消去）
    ThisWorkbook.Worksheets("ファイル名一覧").Activate
    Call 全セルクリア
    Range("A1").Select
    Worksheets("画像一覧").Activate
    Call 全セルクリア
    Call 全画像クリア
        
    Call フォルダ指定
    Call サブフォルダ一覧取得

   ' 画像貼り付け表の作成
    cnt = 1
    myfileNmax = 1
    For n = 1 To UBound(mySubfld)
        Call フォルダ内ファイル取得(n)
        If SafeArrayGetDim(myfname) <> 0 Then
            cnt = UBound(myfname)
        End If
        If myfileNmax <= cnt Then
            myfileNmax = cnt
        End If
        Erase myfname
    Next n
    myfileNmax = myfileNmax - 1  'サブフォルダ内にあるファイルの最大数
    Debug.Print myfileNmax
    
    Call 画像貼り付け表作成
    j = 2
    For n = 1 To UBound(mySubfld)
        Cells(1, j) = mySubfld(n)
        j = j + 1
    Next n
    For i = 1 To myfileNmax + 1
        Cells(i + 1, 1) = i
    Next i

    ' ファイル名入力と画像貼り付け
    j = 2
    For n = 1 To UBound(mySubfld)
        Call フォルダ内ファイル取得(n)
        Worksheets("ファイル名一覧").Select
        Cells(1, j) = mySubfld(n)
        If SafeArrayGetDim(myfname) <> 0 Then
            For i = 2 To UBound(myfname) + 1
                Cells(i, 1) = i - 1
                Cells(i, j) = myfname(i - 1)
            Next i
            
            Worksheets("画像一覧").Select
            Call 画像貼り付け(j)
        End If
        Erase myfname()  'フォルダ毎に処理してるため、一旦空にする
        j = j + 1
    Next n
    Worksheets("画像一覧").Activate
    Range("A1").Select
    
    Application.ScreenUpdating = True
End Sub

Sub バブルソート_API(ByRef myArray() As Variant)
    Dim i, j As Long
    Dim tmp As String

    For i = LBound(myArray) To UBound(myArray)
        For j = i To UBound(myArray)
            If StrCmpLogicalW(StrConv(myArray(i), vbUnicode), StrConv(myArray(j), vbUnicode)) > 0 Then
                tmp = myArray(i)
                myArray(i) = myArray(j)
                myArray(j) = tmp
            End If
       Next j
    Next i
End Sub

Sub フォルダ指定()
    Dim rc As Long
    
    With Application.filedialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
       rc = .Show
       If rc = -1 Then
           myfolder = .SelectedItems.Item(1)
           ChDrive Left(myfolder, 1)
           ChDir myfolder
       End If
    End With
    Debug.Print myfolder
End Sub

Sub サブフォルダ一覧取得()
    Dim myfso, buf As Variant
    Set myfso = CreateObject("scripting.filesystemobject")
    Set buf = CreateObject("scripting.filesystemobject")
    Dim i As Integer

    i = 1
    With myfso.getfolder(myfolder)
    For Each buf In .subfolders
        ReDim Preserve mySubfld(i)
        mySubfld(i) = buf.Name
        i = i + 1
    Next
    End With
    Debug.Print VarType(mySubfld)
    If SafeArrayGetDim(mySubfld) <> 0 Then
        Call バブルソート_API(mySubfld)
    End If
End Sub

Sub フォルダ内ファイル取得(n)
    Dim tmpfile As Variant
    Dim i As Integer
    
    ChDir myfolder & "¥" & mySubfld(n)
    tmpfile = Dir("*.jpg")
    i = 1
    Do While tmpfile <> ""
        ReDim Preserve myfname(i)
        myfname(i) = tmpfile
        tmpfile = Dir()
        i = i + 1
    Loop
    If SafeArrayGetDim(myfname) <> 0 Then
        Call バブルソート_API(myfname)
    End If
End Sub

Sub 画像貼り付け表作成()
    Dim s, t As Integer
    
    For t = 1 To UBound(mySubfld) + 1
    '----------列名箇所のセル枠の作成----------
        Cells(1, t).Select
        Selection.ColumnWidth = セル列の幅
        Selection.RowHeight = 13
        With Selection
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .ShrinkToFit = False
            .MergeCells = False
            .Font.Size = 表のフォント
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        Selection.Merge
        Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
        Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
        Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
        Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
        '----------行名箇所のセル枠の作成----------
        For s = 1 To myfileNmax + 1 + 1 Step 1
            If t = 1 Then
                Range(Cells(s, 1), Cells(s, 1)).Select
                Selection.ColumnWidth = 3
                Selection.RowHeight = セル行の高さ
                With Selection
                    .WrapText = False
                    .AddIndent = False
                    .ShrinkToFit = False
                    .MergeCells = False
                    .Orientation = 90
                    .Font.Size = 表のフォント
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                End With
                Selection.Merge
                Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
                Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
                Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
                Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
            End If
        '----------画像貼り付け箇所に罫線を引く----------
            Cells(s, t).Select
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        Next s
    Next t
End Sub

Sub 画像貼り付け(ByRef j As Integer)
    Dim i As Integer
    Dim objshape As Shape
    Dim myCell As Range
    Dim tmp As Object

    For i = 2 To UBound(myfname) + 1
        Set myCell = Cells(i, j)
        myCell.Select
        Set objshape = ActiveSheet.Shapes.AddPicture( _
            Filename:=myfname(i - 1), _
            linktofile:=False, _
            savewithdocument:=True, _
            Left:=Selection.Left, _
            Top:=Selection.Top, _
            Width:=0, _
            Height:=0)
        '画像サイズと貼り付け位置の調整
        With ActiveSheet.Shapes.Range(objshape.Name)
            .ScaleWidth 1, msoTrue
            .ScaleHeight 1, msoTrue
            .LockAspectRatio = False
            .Width = myCell.Width - 1
            .Height = myCell.Height - 1
            .Left = myCell.Left + (myCell.Width - .Width) / 2
            .Top = myCell.Top + (myCell.Height - .Height) / 2
'            .Line.Weight = 0.5
        End With
    Next i
End Sub

Sub 全画像クリア()
    Dim Shp As Object
    Dim r   As Range

    Cells.Select
    For Each Shp In ActiveSheet.Shapes
        Set r = Range(Shp.TopLeftCell, Shp.BottomRightCell)
        If Not Intersect(r, Selection) Is Nothing Then
           Shp.Delete
        End If
    Next
End Sub

Sub 全セルクリア()
    Cells.Clear
'    ActiveSheet.UsedRange.ClearContents
'    ActiveSheet.UsedRange.ClearFormats
End Sub

以上

<広告>

リンク