Excel VBA 列出具有所有者/作者属性的文件夹中的文件

Question

这可行，但速度很慢：

Option Explicit
Sub GetDetails()
  Dim oShell As Object
  Dim oFile As Object
  Dim oFldr As Object
  Dim lRow As Long
  Dim iCol As Integer
  Dim vArray As Variant
  vArray = Array(0, 3, 10, 20)

  Set oShell = CreateObject("Shell.Application")
  lRow = 1
      Set oFldr = oShell.Namespace("\\mysite\www\docs\f150\group\IDL\collection\")
      With oFldr
        For iCol = LBound(vArray) To UBound(vArray)
          Cells(lRow, iCol + 1) = .getdetailsof(.items, vArray(iCol))
        Next iCol
        For Each oFile In .items
          lRow = lRow + 1
          For iCol = LBound(vArray) To UBound(vArray)
          On Error Resume Next
            Cells(lRow, iCol + 1) = .getdetailsof(oFile, vArray(iCol))
          Next iCol
        Next oFile
      End With
End Sub

我有下面的代码工作，但我仍然无法获得所有者/作者或特定文件类型。

Sub getFiles()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("\\mysite\www\docs\f150\group\IDL\collection")
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
    'print file name
    Cells(i + 1, 1) = objFile.Name
        With Cells(i + 1, 1)
            Cells(i + 1, 1).Select
                Selection.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path
        End With
    'print file path
    Cells(i + 1, 2) = objFile.DateLastModified
    i = i + 1
Next objFile
Columns.AutoFit
End Sub

我正在尝试将某些文件和属性的列表放入 Excel 文档，但代码不断导致 Excel 崩溃。 下面的代码可能有一些冗余，因为我整天都在摆弄它。最终我想获得 .pptx 和 .pdf 文件名、DateLastModified 以及所有者或作者

Sub ListAllFile()
    Application.ScreenUpdating = False

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objFile As Object
    Dim ws As Worksheet

    Dim myExt1 As String
    Dim myExt2 As String
        myExt1 = "*.pptx"
        myExt2 = "*.pdf"

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ws = Worksheets.Add

    'Get the folder object associated with the directory
    Set objFolder = objFSO.GetFolder("\\mysite\www\docs\f150\group\IDL\collection")
    ws.Cells(1, 1).Value = "The current files found in " & objFolder.Name & "are:"

    Set objFile = objFile
    'Loop through the Files collection
    For Each objFile In objFolder.Files
        If StrComp(objFile.Name, myExt1) = 1 Or StrComp(objFile.Name, myExt2) = 1 Then
            Dim strFilePath As Object
            Dim arrHeaders(35)
            Dim i As Integer
            Dim objShell As Object
            Set objShell = CreateObject("Shell.Application")
            Set objFolder = objShell.Namespace("\\mysite\www\docs\f150\group\IDL\collection")
            Set objFileName = objFolder.ParseName(objFile.Name)

            For Each objFile In objFolder.Items
                ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
                ws.Cells(ws.UsedRange.Rows.Count + 0, 2).Value = objFile.DateLastModified
                'This returns the "Owner" as the value for every file (not what I want)
                ws.Cells(ws.UsedRange.Rows.Count + 0, 3).Value = objFolder.GetDetailsOf(objFile, 10)
                'This returns the "Author" as the value for every file (not what I want)
                ws.Cells(ws.UsedRange.Rows.Count + 0, 4).Value = objFolder.GetDetailsOf(objFile, 20)
                'This returns the actual owner
                ws.Cells(ws.UsedRange.Rows.Count + 0, 5).Value = objFolder.GetDetailsOf(strFileName, 10)
                'This returns the actual author
                ws.Cells(ws.UsedRange.Rows.Count + 0, 6).Value = objFolder.GetDetailsOf(strFileName, 20)
            Next
        End If
     Next
    Columns.AutoFit

    'Clean up
    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing
    Set objShell = Nothing
    Set objFileName = Nothing
    Set ws = Nothing
    Application.ScreenUpdating = True
End Sub

Answer 1

我将每个循环变量名称的第二个更改为 objfile1 并在其下方进行了适当的修改：

For Each objfile1 In objFolder.Items
    ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objfile1.Name
    ws.Cells(ws.UsedRange.Rows.Count + 0, 2).Value =    objFile.DateLastModified

注意 DateLastModified 是 objFile 的一个属性，而 Name 属于 objfile1。

希望这会有所帮助。

Answer 2

您可以尝试使用 CMD.exe DIR 命令对其进行一些优化，以及其他一些调整：

Sub Foo()

Dim myExt1         As String
Dim myExt2         As String
Dim searchFolder   As Variant
Dim finalArray     As Object
Dim shellObj       As Object

searchFolder = "\\mysite\www\docs\f150\group\IDL\collection"
myExt1 = "*.pptx"
myExt2 = "*.pdf"
Set finalArray = CreateObject("System.Collections.ArrayList")
Set shellObj = CreateObject("Shell.Application").Namespace(searchFolder)

For Each file In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR " & searchFolder & "\" & myExt1 & " /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
    finalArray.Add CStr(file)
Next

For Each file In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR " & searchFolder & "\" & myExt2 & " /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
    finalArray.Add CStr(file)
Next

For Each file In finalArray.ToArray()
    With Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        .Value = CStr(file)
        .Offset(0, 1).Value = shellObj.GetDetailsOf(CStr(file), 10)
        .Offset(0, 2).Value = shellObj.GetDetailsOf(CStr(file), 20)
    End With
Next

End Sub