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

'***************************************************************
'* 指定フォルダ内の画像情報を取得し新規ブックに出力する
'*--------------------------------------------------------------
'* 概要     | 指定フォルダ内の画像ファイルの情報を取得し
'*          | 新規ブックに出力する
'*          | 参考：https://excel.syogyoumujou.com/vba/image_info.html
'* 引数     | なし
'* 戻り値   | なし
'* 作成日   | 2021.10.14
'*--------------------------------------------------------------
'* 改修履歴 | 2026.04.24
'***************************************************************
Public Sub exportImageInfoToNewWorkbook()
On Error GoTo LBL_ERROR

    '------------------------------
    ' 対象フォルダの選択
    '------------------------------
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象フォルダを選択してください"
        If .Show = True Then
            strFolderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    ' フォルダの存在確認
    If Dir(strFolderPath, vbDirectory) = "" Then Exit Sub

    ' フォルダパスに区切り文字を追加
    strFolderPath = strFolderPath & Application.PathSeparator

    '------------------------------
    ' 画像タイプを配列として設定
    '------------------------------
    Dim varImageType As Variant
    varImageType = Array(".bmp", ".jpg", ".png", ".gif")

    '------------------------------
    ' 画像ファイルパス取得
    '------------------------------
    Dim i           As Long
    Dim strTarget   As String
    Dim colFilePath As New Collection

    For i = 0 To UBound(varImageType)
        ' 指定フォルダからファイルを検索
        strTarget = Dir(strFolderPath & "*" & varImageType(i), vbNormal)
        Do Until strTarget = ""
            ' コレクションに検索に一致したファイルパスを追加
            colFilePath.Add strFolderPath & strTarget
            ' 次のファイルを検索
            strTarget = Dir()
        Loop
    Next i

    If colFilePath.Count = 0 Then
        MsgBox "画像ファイルが見つかりません", vbInformation
        Exit Sub
    End If

    '------------------------------
    ' 新規ブックに出力
    '------------------------------
    Application.ScreenUpdating = False

    ' 新規ブック追加
    Dim shtTarget As Worksheet
    Set shtTarget = Workbooks.Add.Worksheets(1)

    ' 見出し設定
    shtTarget.Range("A1") = "フォルダパス"
    shtTarget.Range("A3:G3") = Array("No.", "画像名", "拡張子", "幅", "高さ", "バイト数", "作成日時")
    shtTarget.Range("A1,A3:G3").Interior.Color = RGB(217, 217, 217)

    ' B列（ファイル名設定列）の表示形式を「文字列」に設定
    shtTarget.Columns(2).NumberFormatLocal = "@"

    ' 画像情報を出力
    Dim lngCount As Long
    Dim varInfo  As Variant

    For i = 1 To colFilePath.Count
        '《指定ファイルパスの画像情報を1次元配列で取得》
        ' ** 引数：対象画像ファイルパス
        '  戻り値：成功：画像ファイル情報の1次元配列
        '                （ファイル名,拡張子,幅,高さ,バイト数,作成日時）
        '          失敗：エラー番号
        varInfo = getImageInfoAsArray1d(colFilePath(i))

        ' 情報を取得できた場合はシートに出力
        If IsArray(varInfo) Then
            lngCount = lngCount + 1
            shtTarget.Cells(3 + lngCount, "A").Value = lngCount
            shtTarget.Cells(3 + lngCount, "B").Resize(1, 1 + UBound(varInfo)).Value = varInfo
        End If
    Next i

    shtTarget.Columns("A:G").AutoFit
    shtTarget.Range("B1") = Left$(strFolderPath, Len(strFolderPath) - 1)
    shtTarget.Range("A1").CurrentRegion.Borders.Weight = xlThin
    shtTarget.Range("A3").CurrentRegion.Borders.Weight = xlThin

    Application.ScreenUpdating = True

    '------------------------------
    ' 終了メッセージ
    '------------------------------
    If lngCount = 0 Then
        MsgBox "画像情報を取得できませんでした", vbExclamation
    Else
        MsgBox "画像情報を出力しました", vbInformation
    End If
    Exit Sub

'------------------------------
' エラー処理
'------------------------------
LBL_ERROR:
    Application.ScreenUpdating = True
    MsgBox "エラー番号：" & Err.Number & vbLf & _
           Err.Description, vbExclamation, "エラーが発生しました"
End Sub

'***************************************************************
'* 指定ファイルパスの画像情報を1次元配列で取得
'*--------------------------------------------------------------
'* 概要     | 指定した画像ファイルパスの情報を1次元配列で返す
'*          | 参考：https://excel.syogyoumujou.com/vba/image_info.html
'* 引数     | 1) pFilePath：画像ファイルパス
'* 戻り値   | Variant型
'*          | 成功  ：画像ファイル情報を格納した1次元配列
'*          |         （ファイル名,拡張子,幅,高さ,バイト数,作成日時）
'*          | エラー：エラー番号
'* 作成日   | 2021.10.14
'*--------------------------------------------------------------
'* 改修履歴 | 2026.04.24
'***************************************************************
Private Function getImageInfoAsArray1d(ByVal pFilePath As String) As Variant
On Error GoTo LBL_ERROR

    '------------------------------
    ' 画像情報取得
    '------------------------------
    Dim lngWidth  As Long
    Dim lngHeight As Long
    ' ImageFile Object
    ' https://learn.microsoft.com/ja-jp/previous-versions/windows/desktop/wiaaut/-wiaaut-imagefile
    With CreateObject("WIA.ImageFile")
        .LoadFile pFilePath
        lngWidth = .Width
        lngHeight = .Height
    End With

    '------------------------------
    ' ファイル情報取得
    '------------------------------
    Dim strBaseName    As String
    Dim strExtension   As String
    Dim dteDateCreated As Date
    Dim strSize        As String

    With CreateObject("Scripting.FileSystemObject")
        ' ベース名と拡張子取得
        strBaseName = .GetBaseName(pFilePath)
        strExtension = .GetExtensionName(pFilePath)
        ' 作成日時取得
        dteDateCreated = .GetFile(pFilePath).DateCreated
        ' サイズ取得
        strSize = Format(.GetFile(pFilePath).Size, "#,###")
    End With

    '------------------------------
    ' 戻り値設定
    '------------------------------
    getImageInfoAsArray1d = Array(strBaseName, strExtension, lngWidth, lngHeight, strSize, dteDateCreated)
    Exit Function

'------------------------------
' エラー処理
'------------------------------
LBL_ERROR:
    getImageInfoAsArray1d = Err.Number
End Function