マクロでファイルのメタ情報を取得

Option Explicit

' ******************************************************
' ************** ユーザー定義型（構造体） **************
' ******************************************************

' 画像のメタ情報（Explorerで取得される詳細情報）を格納するための構造体を定義
Public Type ImageInfo
    name As String              ' ファイル名（例: "IMG_1234.jpg"）
    fullPath As String          ' ファイルの絶対パス（例: "C:\Temp\IMG_1234.jpg"）
    TypeText As String          ' ファイルの種類（例: "JPEG 画像"）
    Size As Double              ' ファイルサイズ（バイト単位）
    DateCreated As Date         ' ファイルの作成日時（ファイルシステム情報）
    DateModified As Date        ' ファイルの最終更新日時（ファイルシステム情報）
    BestDate As Date            ' 最適な日時情報（Explorerの「日付」列、撮影日時、作成日時の優先順で設定）
    DateTaken As Date           ' 撮影日時（EXIF情報。Explorer列から取得）
    Tags As String              ' タグ、キーワード（Explorer列から取得）
    Width As Long               ' 画像の幅（ピクセル）
    Height As Long              ' 画像の高さ（ピクセル）
    Rating As Long              ' 評価（0..5、★の数）
End Type

' ******************************************************
' ************** グローバル変数 **************
' ******************************************************

Private imgFolder As String     ' ユーザーが選択したフォルダのパスを格納
Private imgList() As ImageInfo  ' 抽出したメタデータを格納する配列（ImageInfo構造体の動的配列）

' ******************************************************
' ************** メインプロシージャ **************
' ******************************************************

'ファイルのメタ情報取得
Sub GetFileMetadata()
    
    ' オブジェクトの宣言
    Dim fso As Object, folder As Object, file As Object  ' FileSystemObject関連
    Dim sh As Object, ns As Object, it As Object        ' Shell.Application関連 (sh: Shell, ns: Namespace/Folder, it: Item)
    
    ' 変数の宣言
    Dim ext As String           ' ファイルの拡張子
    Dim cnt As Long, i As Long  ' cnt: 対象ファイル数, i: 配列インデックス
    Dim dimText As String, w As Long, h As Long ' 寸法情報（文字列、幅、高さ）

    ' 1. フォルダの選択と初期化
    
    ' Shell Namespace（Explorerの列情報取得に使用するShellオブジェクトを作成）
    Set sh = CreateObject("Shell.Application")
    
    ' ユーザーにフォルダ選択ダイアログを表示（初期パスをC:\Tempに設定）
    ' ns には選択されたフォルダの Shell.Folder オブジェクトが格納される
    Set ns = sh.BrowseForFolder(0, "対象フォルダを選択してください", 0, "C:\Temp")

    ' ユーザーがキャンセルした場合のチェック
    If ns Is Nothing Then Exit Sub

    ' 選択されたフォルダのパスをフルパスで取得
    imgFolder = ns.Self.Path

    ' 2. FileSystemObject (FSO) でファイル走査の準備
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' FSOでフォルダオブジェクトを取得
    Set folder = fso.GetFolder(imgFolder)

    ' 3. 対象ファイル（jpg/jpeg）のカウント
    
    ' フォルダ内のファイルを走査し、対象のJPEGファイル数 (cnt) を数える
    cnt = 0
    For Each file In folder.Files
        ext = LCase$(fso.GetExtensionName(file.name)) ' 拡張子を小文字化
        If ext = "jpg" Or ext = "jpeg" Then cnt = cnt + 1
    Next
    
    ' 対象ファイルが0の場合の処理
    If cnt = 0 Then
        MsgBox "画像が見つかりません。", vbExclamation
        Exit Sub
    End If

    ' 4. 配列確保
    
    ' カウントした数に合わせて、ImageInfo配列のサイズを確保 (1ベース)
    ReDim imgList(1 To cnt)

    ' 5. メタ情報の収集と配列への格納
    
    i = 0 ' 配列インデックスをリセット
    For Each file In folder.Files
        ext = LCase$(fso.GetExtensionName(file.name))
        
        ' JPEGファイルのみを対象にする
        If ext = "jpg" Or ext = "jpeg" Then
            i = i + 1 ' 配列インデックスをインクリメント
            
            ' 1) 基本情報（ファイルシステムから取得）
            With imgList(i)
                .name = file.name
                .fullPath = file.Path
                .Size = CDbl(file.Size) ' Double型に変換
                .DateCreated = file.DateCreated
                .DateModified = file.DateLastModified
                .TypeText = "JPEG 画像" ' Explorerで情報が取得できない場合の初期値
            End With

            ' 2) Explorer列からメタデータ取得（Shell.Application機能）
            If Not ns Is Nothing Then
                ' ファイル名から Shell.FolderItem オブジェクト（it）を取得
                Set it = ns.ParseName(file.name)
                
                If Not it Is Nothing Then
                    With imgList(i)
                        
                        ' ファイルの種類（TypeText）をExplorer情報で上書き
                        ' GetDetailByHeader関数で「種類」「Item type」「Type」を優先順に探す
                        .TypeText = GetDetailByHeader(ns, it, "種類", "Item type", "Type")
                        
                        ' BestDate（最適な日付）の取得と補完
                        ' Explorerの「日付」列（あれば）→「撮影日時」→ファイル作成日時の順に試す
                        .BestDate = ParseDateLoose(GetDetailByHeader(ns, it, "日付", "日付時刻", "Date"))
                        If .BestDate = 0 Then .BestDate = ParseDateLoose(GetDetailByHeader(ns, it, "撮影日時", "Date taken"))
                        If .BestDate = 0 Then .BestDate = .DateCreated ' 最終的にファイル作成日時で補完
                        
                        ' 撮影日時（DateTaken）を個別に取得
                        .DateTaken = ParseDateLoose(GetDetailByHeader(ns, it, "撮影日時", "Date taken"))
                        
                        ' タグ/キーワードを取得
                        .Tags = GetDetailByHeader(ns, it, "タグ", "Tags", "Keywords")

                        ' 幅と高さの取得（「幅」「高さ」列から）
                        ' 取得した文字列から数字のみを抽出し、CLngでLong型に変換
                        w = CLng(ExtractOnlyNumbers(GetDetailByHeader(ns, it, "幅", "Width")))
                        h = CLng(ExtractOnlyNumbers(GetDetailByHeader(ns, it, "高さ", "Height")))
                        If .Width = 0 Then .Width = w ' 既にWidth/Heightが設定されていなければ適用
                        If .Height = 0 Then .Height = h
                        
                        ' 寸法情報の取得（「大きさ」列から）
                        ' "4000 x 3000" のような文字列をパースし、幅と高さに設定
                        dimText = GetDetailByHeader(ns, it, "大きさ", "寸法", "Dimensions")
                        ParseDimensions dimText, w, h ' w, h にパース結果がByRefで返る
                        If .Width = 0 Then .Width = w   ' 幅/高さが未設定の場合に、パース結果を適用
                        If .Height = 0 Then .Height = h

                        ' 評価（Rating）の取得（TryGetShellRating関数による優先的な取得）
                        Dim r As Long
                        ' ExtendedProperty経由でRatingを取得を試みる
                        If TryGetShellRating(ns, it, r) Then
                            .Rating = r
                        Else
                            ' 失敗した場合、Explorer列の文字列から評価をパース
                            .Rating = ParseRatingString(GetDetailByHeader(ns, it, "評価", "Rating"))
                        End If
                    End With
                End If
            End If


            ' 3) BestDateの最終的なフォールバック（二重チェック）
            With imgList(i)
                If .BestDate = 0 Then ' BestDateがまだ未設定（0）の場合
                    If .DateTaken <> 0 Then
                        .BestDate = .DateTaken
                    Else
                        .BestDate = .DateCreated ' 最終手段としてファイル作成日時を設定
                    End If
                End If
            End With
        End If
    Next ' For Each file

    ' 6. オブジェクトの解放（ガベージコレクション）
    Set it = Nothing
    Set ns = Nothing
    Set sh = Nothing
    Set folder = Nothing
    Set fso = Nothing
    
    ' ここに、imgList配列を使った後続処理（例: Excelシートへの書き出し）を記述
    Call WriteMetadataToSheet(imgList)
End Sub


' ******************************************************
' ************** 後続処理用プロシージャ **************
' ******************************************************

' --------------------------------------------------------------------------------
' imgList配列の内容をシート「メタデータ」に書き出す
' --------------------------------------------------------------------------------
Public Sub WriteMetadataToSheet(ByRef dataList() As ImageInfo)
    
    Dim ws As Worksheet
    Dim i As Long
    Dim lastRow As Long
    
    ' 対象シート名の設定
    Const SHEET_NAME As String = "メタデータ"
    
    ' -----------------------------------
    ' 1. シートの準備
    ' -----------------------------------
    
    ' シート「メタデータ」の存在を確認し、なければ作成
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(SHEET_NAME)
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws.name = SHEET_NAME
        
        ' ヘッダーが未記入の場合に備えて（もし未記入ならここで書き込む）
        ' ws.Cells(1, 1).Value = "名前"
        ' ...
    End If
    On Error GoTo 0
    
    ' -----------------------------------
    ' 2. 既存データのクリア（2行目以降）
    ' -----------------------------------
    
    ' 1行目はヘッダーなので残し、2行目以降の既存データをクリアする
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastRow >= 2 Then
        ' データが存在する場合、2行目から最終行までをクリア
        ws.Range("A2:J" & lastRow).ClearContents
    End If
    
    ' -----------------------------------
    ' 3. 配列のデータをシートに書き出し
    ' -----------------------------------
    
    ' imgList配列が空の場合のチェック (LBound > UBound)
    If UBound(dataList) < LBound(dataList) Then Exit Sub
    
    For i = LBound(dataList) To UBound(dataList)
        ' 書き出し対象の行番号 (ヘッダー(1行目) + インデックス(i))
        ' LBoundが1だとすると、i=1で2行目、i=2で3行目
        Dim currentRow As Long
        currentRow = i + 1
        
        With dataList(i)
            ws.Cells(currentRow, "A").Value = .name
            ' B列: 日付時刻 (BestDate)
            ws.Cells(currentRow, "B").Value = .BestDate
            ws.Cells(currentRow, "B").NumberFormat = "yyyy/mm/dd hh:mm:ss" ' 日付時刻形式を適用
            
            ws.Cells(currentRow, "C").Value = .TypeText
            ' D列: サイズ
            ws.Cells(currentRow, "D").Value = .Size
            ws.Cells(currentRow, "D").NumberFormat = "#,##0" ' 数値形式を適用
            
            ws.Cells(currentRow, "E").Value = .Tags
            ws.Cells(currentRow, "F").Value = .DateCreated
            ws.Cells(currentRow, "F").NumberFormat = "yyyy/mm/dd hh:mm:ss"
            
            ws.Cells(currentRow, "G").Value = .DateModified
            ws.Cells(currentRow, "G").NumberFormat = "yyyy/mm/dd hh:mm:ss"
            
            ws.Cells(currentRow, "H").Value = .DateTaken
            ws.Cells(currentRow, "H").NumberFormat = "yyyy/mm/dd hh:mm:ss"
            
            ' I列: 大きさ (Width x Height) の形式で結合
            ws.Cells(currentRow, "I").Value = .Width & " x " & .Height
            
            ws.Cells(currentRow, "J").Value = .Rating
        End With
    Next i
    
    ' -----------------------------------
    ' 4. 表示の調整
    ' -----------------------------------
    ws.Columns.AutoFit
    
End Sub




' ******************************************************
' ************** ユーティリティ関数 **************
' ******************************************************

' --------------------------------------------------------------------------------
' Explorer列から日本語/英語ヘッダ名で値を取得
' （複数の候補ヘッダ（ParamArray headers）を順に探し、最初に見つかった値を返す）
' --------------------------------------------------------------------------------
Private Function GetDetailByHeader(ns As Object, item As Object, ParamArray headers()) As String
    Dim i As Long, h As Variant, name As String, val As String
    ' エラーが発生しても処理を中断しない（存在しない列を参照した場合などに備える）
    On Error Resume Next
    
    For Each h In headers ' 候補のヘッダー名（例: "日付", "Date", "日付時刻"）を順に試す
        For i = 0 To 400 ' 0から最大400番目までのExplorer列を走査
            ' 列ヘッダー名を取得
            name = ns.GetDetailsOf(Nothing, i)
            
            If Len(name) > 0 Then
                ' 列名が候補名と一致するかをテキスト比較（大文字小文字無視）でチェック
                If StrComp(name, CStr(h), vbTextCompare) = 0 Then
                    ' ヘッダー名が一致したら、その列インデックス(i)を使って項目の値を取得
                    val = ns.GetDetailsOf(item, i)
                    If Len(val) > 0 Then
                        GetDetailByHeader = val ' 値が取得できたらそれを返して関数を終了
                        Exit Function
                    End If
                End If
            End If
        Next i
    Next h
    
    On Error GoTo 0 ' エラーハンドラをリセット
End Function


' --------------------------------------------------------------------------------
' 日付文字列の緩やかなパース
' ・EXIF形式 "YYYY:MM:DD HH:MM:SS" に対応（コロン区切り）
' ・通常のロケール日付（スラッシュ区切りなど）にも対応
' --------------------------------------------------------------------------------
Private Function ParseDateLoose(ByVal s As String) As Date
    On Error Resume Next
    If Len(s) = 0 Then Exit Function

    ' 1. EXIF形式のパース処理
    ' EXIFの撮影日時は "YYYY:MM:DD HH:MM:SS" の形式になっていることが多い
    If InStr(s, ":") >= 5 And InStr(s, " ") > 0 Then ' 年の部分にコロンとスペースがあるかチェック
        Dim parts() As String, dpart As String, tpart As String, d() As String, tt() As String
        parts = Split(s, " ")
        dpart = parts(0): tpart = parts(1) ' 日付部分と時刻部分に分割
        d = Split(dpart, ":"): tt = Split(tpart, ":") ' 日付と時刻をコロンで分割
        
        If UBound(d) = 2 And UBound(tt) >= 1 Then ' 日付部分が(年,月,日)と時刻部分(時,分,秒)に分割できているか
            ' DateSerialとTimeSerialを使ってDate型に結合
            ParseDateLoose = DateSerial(CInt(d(0)), CInt(d(1)), CInt(d(2))) + _
                             TimeSerial(CInt(tt(0)), CInt(tt(1)), IIf(UBound(tt) >= 2, CInt(tt(2)), 0)) ' 秒がなければ0を設定
            Exit Function
        End If
    End If

    ' 2. 通常ロケール解釈のための前処理
    ' 文字化けや余計な文字を削除し、数字と日付/時刻の区切り文字のみを抽出
    s = ExtractAllowedChars(s) ' ExtractAllowedCharsで"0-9/: "のみを抽出

    ' 3. 抽出後の文字列をCDateで解釈
    If IsDate(s) Then
        ParseDateLoose = CDate(s)
    End If

    On Error GoTo 0
End Function


' ----------------------------------------------------------------------
' 目的: 文字列から数字、スラッシュ、コロン、半角スペースのみを抽出する。
' (ParseDateLoose関数内で、CDateに渡す前のクリーニングに使用)
' ----------------------------------------------------------------------
Private Function ExtractAllowedChars(ByVal originalString As String) As String
    Dim i As Long, char As String, resultString As String
    Const ALLOWED_CHARS As String = "0123456789/: " ' 許可文字リスト
    resultString = ""
    
    For i = 1 To Len(originalString)
        char = Mid(originalString, i, 1)
        If InStr(ALLOWED_CHARS, char) > 0 Then
            resultString = resultString & char
        End If
    Next i
    
    ExtractAllowedChars = resultString
End Function


' ----------------------------------------------------------------------
' 目的: 文字列から数字（0～9）のみを抽出する。
' (幅や高さの文字列から数値部分を抽出するために使用)
' ----------------------------------------------------------------------
Private Function ExtractOnlyNumbers(ByVal originalString As String) As String
    Dim i As Long, char As String, resultString As String
    resultString = ""
    
    For i = 1 To Len(originalString)
        char = Mid(originalString, i, 1)
        ' Charが "0"～"9" の範囲にあるかを確認
        If char >= "0" And char <= "9" Then
            resultString = resultString & char
        End If
    Next i
    
    ExtractOnlyNumbers = resultString
End Function


' ----------------------------------------------------------------------
' 「大きさ」列の文字列 "4000 x 3000" など → 幅・高さにパース
' （×/x、ピクセル/pixels などの単位文字を正規化して対応）
' ----------------------------------------------------------------------
Private Sub ParseDimensions(ByVal s As String, ByRef w As Long, ByRef h As Long)
    Dim parts() As String
    
    ' 全角「×」や単位文字を半角「x」や空文字に置換して正規化
    s = Replace(s, "×", "x")
    s = Replace(s, "ピクセル", "")
    s = Replace(s, "pixels", "")
    s = Trim$(s)
    
    If InStr(s, "x") = 0 Then Exit Sub ' 区切り文字 'x' がなければ終了
    
    parts = Split(s, "x") ' "x"で分割
    
    If UBound(parts) = 1 Then ' 分割結果が2要素（幅と高さ）の場合
        ' それぞれの要素から数字のみを抽出し、val関数で数値化して幅と高さに設定
        w = val(ExtractOnlyNumbers(Trim$(parts(0))))
        h = val(ExtractOnlyNumbers(Trim$(parts(1))))
    End If
End Sub

' ----------------------------------------------------------------------
' ShellのExtendedPropertyを使って評価（Rating）を確実に取得を試みる
' ----------------------------------------------------------------------
Private Function TryGetShellRating(ns As Object, it As Object, ByRef rating05 As Long) As Boolean
    Dim v As Variant, s As String

    ' 1. System.SimpleRating (0..5の数値) を直接取得
    On Error Resume Next
    v = it.ExtendedProperty("System.SimpleRating") ' 0..5
    On Error GoTo 0
    
    If IsNumeric(v) Then
        rating05 = CLng(v)
        TryGetShellRating = True
        Exit Function
    End If

    ' 2. System.RatingText ("3 個の星" などの文字列) を取得しパース
    On Error Resume Next
    v = it.ExtendedProperty("System.RatingText") ' "未評価" / "3 個の星" 等
    On Error GoTo 0
    s = ""
    If Not IsEmpty(v) And Not IsNull(v) Then s = CStr(v)
    
    If Len(s) > 0 Then
        rating05 = ParseRatingString(s)
        TryGetShellRating = True
        Exit Function
    End If

    ' 3. 列名（"評価", "Rating"）経由で取得しパース
    s = GetDetailByHeader(ns, it, "評価", "Rating")
    If Len(s) > 0 Then
        rating05 = ParseRatingString(s)
        TryGetShellRating = True
        Exit Function
    End If
    
    TryGetShellRating = False ' どこからも取得できなかった場合
End Function


' ----------------------------------------------------------------------
' 評価の文字列→0..5（★×5）に変換
' ・"未評価"/"unrated"/"3 個の星"/数値（0..5）などに対応
' ----------------------------------------------------------------------
Public Function ParseRatingString(ByVal s As String) As Long
    Dim t As String, stars As Long, n As Double
    t = Trim$(s)
    If Len(t) = 0 Then Exit Function

    ' 1. "未評価" / "unrated" のチェック
    If InStr(1, t, "未評価", vbTextCompare) > 0 Or InStr(1, t, "unrated", vbTextCompare) > 0 Then
        ParseRatingString = 0
        Exit Function
    End If

    ' 2. ★の個数を数える
    stars = Len(t) - Len(Replace(t, "★", ""))
    If stars > 0 Then
        If stars > 5 Then stars = 5 ' 5を超える場合は5に制限
        ParseRatingString = stars
        Exit Function
    End If

    ' 3. 数値解釈（例: "3", "3.0", "80" (パーセント評価の可能性)）
    n = val(t)
    If n <= 0 Then
        ParseRatingString = 0
    Else
        ' nが1?5ならそのまま★の数として、それ以外（例: 80%）はそのまま数値を返している
        ' ここでは、ExtendedPropertyで取得できなかった場合のフォールバックとしてCLng(n)を返す
        ParseRatingString = CLng(n)
    End If
End Function