トップ　>　汎用コード　>　フォルダ内の画像ファイル情報を一括取得

'+++ 宣言セクション +++
Private myWB      As Workbook
Private varImgTyp As Variant

Sub Image_information_acquisition() '

    varImgTyp = Array(".bmp", ".jpg", ".png", ".gif") '画像タイプ

    Dim strDirPath As String
    'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then strDirPath = .SelectedItems(1)
    End With
    If Len(strDirPath) = 0 Then Exit Sub
    'フォルダの存在確認
    If Dir(strDirPath, vbDirectory) = "" Then Exit Sub
    'フォルダ内画像検索
    Call Search_Images(strDirPath)
End Sub

Private Sub Search_Images(ByVal strPath As String) 'フォルダ内画像検索　strPath：対象フォルダ
    Dim strTarget As String   '対象画像名
    Dim lngCount  As Long     '対象画像数
    Dim i         As Long     'カウンタ
    With Application
        .ScreenUpdating = False             '画面更新停止
        .DisplayAlerts = False              '確認メッセージ非表示
        strPath = strPath & .PathSeparator  'フォルダパスにフォルダ区切り文字追加
        Set myWB = Workbooks.Add            '書き込み用ブック追加
        With myWB.Worksheets(1)
            .Range("A1:B1") = Array("フォルダパス", strPath)
            .Range("A2:E2") = Array("連番", "画像名", "幅", "高さ", "バイト")
        End With
        On Error Resume Next
        For i = LBound(varImgTyp) To UBound(varImgTyp)
            strTarget = Dir(strPath & "*" & varImgTyp(i)) 'フォルダ内の画像を検索
            Do Until strTarget = ""         '画像ファイルがなければループから抜ける
                lngCount = lngCount + 1
                Call Get_Data(strPath, strTarget, lngCount) '画像情報取得
                strTarget = Dir()           '次の画像ファイルを検索
            Loop
        Next
        On Error GoTo 0
        strTarget = Dir("")
        If 0 = lngCount Then
            myWB.Close False
            MsgBox "画像ファイルが見つかりません", vbInformation
        Else
            myWB.Worksheets(1).Columns("A:E").AutoFit
        End If
        Set myWB = Nothing
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

Private Sub Get_Data(dirPath As String, imgName As String, imgNum As Long) '画像情報取得
    Dim mySP As Shape   '追加シェープ
    Dim w    As Long    '幅
    Dim h    As Long    '高さ
    Dim b    As String  'バイト
    Set mySP = ActiveSheet.Shapes.AddPicture(dirPath & imgName, False, True, 0, 0, 0, 0)
    With mySP
        .LockAspectRatio = msoTrue
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue
        w = CLng(.Width * 4 / 3)
        h = CLng(.Height * 4 / 3)
        .Delete
    End With
    b = Format(FileLen(dirPath & imgName), "#,###")
    myWB.Worksheets(1).Cells(2 + imgNum, "A").Resize(1, 5) = Array(imgNum, imgName, w, h, b)
End Sub