如何修改VBA实现遍历父文件夹及子文件夹获取照片详细属性

核心修改内容 #

• 添加递归遍历逻辑：实现对选中文件夹下所有子文件夹的深度遍历
• 增加照片文件过滤：仅处理常见图片格式（可按需扩展）
• 优化代码结构：将文件处理逻辑拆分到独立过程，提升可读性和可维护性

完整改进代码 #

Sub ReadAllPhotos()
    Dim sRootFolder As String
    ' 选择根文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择要遍历的根文件夹"
        If .Show = -1 Then
            sRootFolder = .SelectedItems(1)
        Else
            Exit Sub ' 用户取消选择
        End If
    End With
    
    ' 初始化表头
    With ActiveSheet
        .Cells(1, 1).Value = "文件路径"
        .Cells(1, 2).Value = "文件名"
        .Cells(1, 3).Value = "创建日期"
        .Cells(1, 4).Value = "拍摄日期"
        .Cells(1, 5).Value = "相机厂商"
        .Cells(1, 6).Value = "相机型号"
        ' 表头加粗
        .Range("A1:F1").Font.Bold = True
    End With
    
    ' 初始化Shell对象和行号
    Dim oShell As Object
    Set oShell = CreateObject("Shell.Application")
    Dim currentRow As Long
    currentRow = 2
    
    ' 启动递归遍历
    TraverseFolder oShell, sRootFolder, currentRow
    
    MsgBox "照片属性提取完成，共处理 " & currentRow - 2 & " 个文件", vbInformation
End Sub

' 递归遍历文件夹的过程
Private Sub TraverseFolder(oShell As Object, folderPath As String, ByRef rowNum As Long)
    Dim oDir As Object
    Set oDir = oShell.Namespace(folderPath)
    
    Dim oItem As Object
    ' 处理当前文件夹中的文件
    For Each oItem In oDir.Items
        ' 过滤照片文件（可根据需要添加更多格式）
        If IsPhotoFile(oItem.Name) Then
            With ActiveSheet
                .Cells(rowNum, 1).Value = oItem.Path
                .Cells(rowNum, 2).Value = oItem.Name
                .Cells(rowNum, 3).Value = oDir.GetDetailsOf(oItem, 4) ' 创建日期
                .Cells(rowNum, 4).Value = oDir.GetDetailsOf(oItem, 12) ' 拍摄日期
                .Cells(rowNum, 5).Value = oDir.GetDetailsOf(oItem, 30) ' 相机厂商
                .Cells(rowNum, 6).Value = oDir.GetDetailsOf(oItem, 32) ' 相机型号
            End With
            rowNum = rowNum + 1
        End If
    Next oItem
    
    ' 遍历子文件夹并递归调用
    Dim oSubFolder As Object
    For Each oSubFolder In oDir.Items
        If oSubFolder.IsFolder Then
            TraverseFolder oShell, oSubFolder.Path, rowNum
        End If
    Next oSubFolder
End Sub

' 判断是否为照片文件的辅助函数
Private Function IsPhotoFile(fileName As String) As Boolean
    Dim photoExts As Variant
    ' 定义常见照片格式，可按需扩展
    photoExts = Array("jpg", "jpeg", "png", "bmp", "tiff", "raw", "cr2", "nef", "dng")
    
    Dim ext As String
    ext = LCase(Right(fileName, Len(fileName) - InStrRev(fileName, ".")))
    
    ' 检查扩展名是否在列表中
    Dim i As Integer
    For i = LBound(photoExts) To UBound(photoExts)
        If ext = photoExts(i) Then
            IsPhotoFile = True
            Exit Function
        End If
    Next i
    IsPhotoFile = False
End Function

代码说明 #

1. 文件夹选择：保留原有的文件夹选择对话框，用户可指定要遍历的根目录
2. 递归遍历：TraverseFolder过程会先处理当前文件夹的照片，再遍历所有子文件夹并重复该操作，实现全目录覆盖
3. 照片过滤：IsPhotoFile函数通过扩展名判断文件是否为照片，默认包含常见格式，可自行添加更多格式（如相机RAW格式）
4. 属性获取：沿用原代码中GetDetailsOf的索引值，对应文件「详细信息」中的属性；注意：部分属性索引可能因Windows版本略有差异，若出现属性错误可自行调整索引
5. 用户反馈：遍历完成后弹出消息框，显示处理的文件总数

内容的提问来源于stack exchange，提问作者Jim Aamoth