使用VBA获取“详细信息”选项卡中列出的属性

Question

我正在尝试获取文件“详细信息”选项卡中的属性列表：

我有这个 VBA，但它只在当前文件夹中查找。 我希望能够从父文件夹开始，然后查看所有子文件夹。 我的目标是找到计算机上的所有照片，并提供具有特定属性的所有文件和位置的列表。

这是VBA。

Sub readAll()
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            sFolder = .SelectedItems(1)
        End If
    End With
    
    Dim sFile As Variant
    Dim oShell: Set oShell = CreateObject("Shell.Application")
    Dim oDir:   Set oDir = oShell.Namespace(sFolder & "\")
    
    ActiveSheet.Cells(1, 1).Value = "File Path"
    ActiveSheet.Cells(1, 2).Value = "File Name"
    ActiveSheet.Cells(1, 3).Value = "Date Created"
    ActiveSheet.Cells(1, 4).Value = "Date Taken"
    ActiveSheet.Cells(1, 5).Value = "Camera Maker"
    ActiveSheet.Cells(1, 6).Value = "Camera Model"
    
    y = 2
    For Each sFile In oDir.Items
        ActiveSheet.Cells(y, 1).Value = sFile.Path
        ActiveSheet.Cells(y, 2).Value = sFile.Name
        ActiveSheet.Cells(y, 3).Value = oDir.GetDetailsOf(sFile, 4)
        ActiveSheet.Cells(y, 4).Value = oDir.GetDetailsOf(sFile, 12)
        ActiveSheet.Cells(y, 5).Value = oDir.GetDetailsOf(sFile, 30)
        ActiveSheet.Cells(y, 6).Value = oDir.GetDetailsOf(sFile, 32)
        y = y + 1
    Next
End Sub

Answer 1

这对我有用：

Sub readAll()
    
    Dim sFolder As Variant, ws As Worksheet, col As New Collection
    Dim itm As Variant, oShell As Object, oDir As Object, y As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            col.Add .SelectedItems(1) 'start with this folder
        Else
            Exit Sub
        End If
    End With
    
    Set ws = ActiveSheet
    ws.UsedRange.Cells.Clear
    
    ws.Cells(1, 1).Resize(1, 6).Value = Array( _
            "File Path", "File Name", "Date Created", _
            "Date Taken", "Camera Maker", "Camera Model")
    
    y = 2
    Set oShell = CreateObject("Shell.Application")
    Do While col.count > 0
        Set oDir = oShell.Namespace(col(1)) 'get the next folder to list files for
        col.Remove 1                        '...and remove it from the queue
        
        For Each itm In oDir.Items
            If itm.isfolder Then
                col.Add itm.Path 'if a folder, queue for processing
            Else
                'list file attributes
                ws.Cells(y, 1).Resize(1, 6).Value = Array( _
                    itm.Path, _
                    itm.Name, _
                    oDir.GetDetailsOf(itm, 4), _
                    oDir.GetDetailsOf(itm, 12), _
                    oDir.GetDetailsOf(itm, 30), _
                    oDir.GetDetailsOf(itm, 32))
                y = y + 1
            End If
        Next
    Loop
End Sub