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

'------------------------------------------------------------------------------
' 指定フォルダ内の画像情報取得し新規ブックに出力する
'------------------------------------------------------------------------------
'［作成日］2021.10.14　［更新日］2025.04.05
' https://excel.syogyoumujou.com/vba/image_info.html
'------------------------------------------------------------------------------
Public Sub 画像情報の一括取得と出力()

    '----------------------------
    ' 対象フォルダの選択
    '----------------------------
    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
    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次元配列で取得》
        ' ** 引数：対象画像ファイルパス
        '  戻り値：成功：画像ファイル情報の１次元配列(ファイル名,拡張子,幅,高さ,バイト数,作成日時)
        '          失敗：エラー番号
        varInfo = getArray1dImageInfomation(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
    shtTarget.Columns("A:G").AutoFit
    shtTarget.Range("B1") = Left$(strFolderPath, Len(strFolderPath) - 1)
    
    Application.ScreenUpdating = True

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

'------------------------------------------------------------------------------
' 指定ファイルパスの画像情報を1次元配列で取得
'------------------------------------------------------------------------------
'［引数］
'   FilePath ：画像ファイルパス
'［戻り値］
'   成功：画像ファイル情報(※)が代入された1次元配列
'         (※)ファイル名,拡張子,幅,高さ,バイト数,作成日時
'   失敗：エラー番号
'［作成日］2021.10.14　［更新日］2025.04.05
' https://excel.syogyoumujou.com/vba/image_info.html
'------------------------------------------------------------------------------
Private Function getArray1dImageInfomation(ByVal FilePath 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 FilePath
    
        ' 幅と高さ取得
        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(FilePath)
        strExtension = .GetExtensionName(FilePath)
        ' 作成日時取得
        dteDateCreated = .GetFile(FilePath).DateCreated
        ' サイズ取得
        strSize = Format(.GetFile(FilePath).Size, "#,###")
    End With
    
    '----------------------------
    ' 戻り値設定
    '----------------------------
    getArray1dImageInfomation = Array(strBaseName, strExtension, lngWidth, lngHeight, strSize, dteDateCreated)
    
    Exit Function
'----------------------------
' エラー処理
'----------------------------
LBL_ERROR:
    getArray1dImageInfomation = Err.Number
End Function