Question

我正在尝试优化我编写的微软单词中的先前vba自动化，它循环通过某种类型的文件（科学文章）（rtf / doc / docx）并提取每个文件中所有单词的列表，然后它将此单词列表与另一个常用单词列表（6000字左右）进行比较，以排除这些文件中的常用单词并获得较不频繁的单词，然后用户可以选择导出和/或突出显示这些不常见的单词单词见下图：

现在，我编写了递归函数，使用shell对象列出文件类型（doc或docx或rtf），因为我读取它比文件系统对象更快，因为我没有测试两者的性能，下面的代码显示当我使用早期绑定工作正常时的功能

Sub test_list()
    Dim t As Double
    t = Timer
    Call ListItemsInFolder("C:\Users\Administrator\Desktop\", False)
    Debug.Print Timer - t

End Sub

Function ListItemsInFolder(FolderPath As String, LookInSubFolders As Boolean, Optional ByVal SearchedFileType As String = ".docx")
    Dim PathsDict As Object
    Set PathsDict = CreateObject("Scripting.Dictionary")
    Dim ShellAppObject As New Shell
    Dim fldItem As ShellFolderItem
    Dim i As Long
    i = 0
    '----------------------------------------------------------------------------------------------------------------------
    'Shell's Namespace object holds onto many different and useful properties that can be used to extract information
    'In this code we have used its FileSystemObject equivalents
    '----------------------------------------------------------------------------------------------------------------------
    With ShellAppObject.NameSpace(FolderPath)
        For Each fldItem In .Items
            '----------------------------------------------------------------------------------------------------------------------
            'The code tends to error when it comes across a zip file which in turn may contain a folder. The code then gives you
            'an RTE so to bypass this possibility we use following check of verifying .zip
            '----------------------------------------------------------------------------------------------------------------------
            'vbTextCompare ==> negelct case sensitivity
            Select Case InStr(1, fldItem.Parent, ".zip", vbTextCompare)
            Case 0    'its not a zip file
                'check if the current item is a folder
                If (fldItem.IsFolder) Then    'the item is a folder
                    'to get the folder path use
                    'Debug.Print fldItem.Path
                    'to get the folder name use
                    'Debug.Print fldItem.Name
                Else    'the item is a file

                    'check if the file is (docx/doc/rtf/txt) accoriding to func input
                    Select Case InStr(1, fldItem.Name, SearchedFileType, vbTextCompare)
                    Case Is > 0
                        'add those files to the dictionary
                        PathsDict.Add Key:=i, Item:=fldItem.Path
                        i = i + 1
                        'to get the parent folder path
                        'Debug.Print Left(fldItem.Path, InStrRev(fldItem.Path, fldItem.Name) - 2)
                        'to get the file name
                        'Debug.Print fldItem.Name
                        'to get the file path
                        'Debug.Print fldItem.Path
                    Case 0
                        'neglect other file types
                    End Select
                End If

                'pass the folder item as a subfolder to the same function for further processing
                If fldItem.IsFolder And LookInSubFolders Then ListItemsInFolder fldItem.Path, LookInSubFolders

            Case Else    'its a zip file
                'do nothing and bypass it
            End Select
        Next fldItem
    End With
    ListItemsInFolder = PathsDict.Items
    Set ShellAppObject = Nothing
    Set PathsDict = Nothing
End Function

现在，当我尝试使用后期绑定时，我收到错误 “对象变量或未设置块变量” 。 ..错误出现在以下的最后一行：

Function ListItemsInFolder(FolderPath As String, LookInSubFolders As Boolean, Optional ByVal SearchedFileType As String = ".docx")
    Dim PathsDict As Object
    Set PathsDict = CreateObject("Scripting.Dictionary")

    Dim ShellAppObject As Object
    Set ShellAppObject = CreateObject("Shell.Application")

    Dim fldItem As Variant 'used to loop inside shell folders collection
    Dim i As Long
    i = 0
    '----------------------------------------------------------------------------------------------------------------------
    'Shell's Namespace object holds onto many different and useful properties that can be used to extract information
    'In this code we have used its FileSystemObject equivalents
    '----------------------------------------------------------------------------------------------------------------------
    With ShellAppObject.NameSpace(FolderPath)

并且变量“fldItem”为空。我错过了什么？

Answer 1

您的字符串变量是问题... ShellAppObject.NameSpace工作路径需要是带引号的文件夹路径...＆＃34; C：\ Windows＆＃34;而不是C：\ Windows这是与字符串变量一起传递的内容。另外我认为你需要在使用With ... End With之前实例化文件夹对象。下面的工作脚本：

Sub test_list()
    Dim t As Double
    t = Timer
    Call ListItemsInFolder("c:\windows", False)
    Debug.Print Timer - t

End Sub

Function ListItemsInFolder(FolderPath As String, LookInSubFolders As Boolean, Optional ByVal SearchedFileType As String = ".docx")
    Dim PathsDict As Object
    Dim ShellAppObject As Object
    Dim objFolder As Object
    Dim fldItem As Object
    Dim i As Long
    Set PathsDict = CreateObject("Scripting.Dictionary")
    Set ShellAppObject = CreateObject("Shell.Application")
    Set objFolder = ShellAppObject.Namespace("" & FolderPath & "")
    i = 0
    '----------------------------------------------------------------------------------------------------------------------
    'Shell's Namespace object holds onto many different and useful properties that can be used to extract information
    'In this code we have used its FileSystemObject equivalents
    '----------------------------------------------------------------------------------------------------------------------
    With objFolder
        For Each fldItem In .Items
            '----------------------------------------------------------------------------------------------------------------------
            'The code tends to error when it comes across a zip file which in turn may contain a folder. The code then gives you
            'an RTE so to bypass this possibility we use following check of verifying .zip
            '----------------------------------------------------------------------------------------------------------------------
            'vbTextCompare ==> negelct case sensitivity
            Select Case InStr(1, fldItem.Parent, ".zip", vbTextCompare)
            Case 0    'its not a zip file
                'check if the current item is a folder
                If (fldItem.IsFolder) Then    'the item is a folder
                    'to get the folder path use
                    'Debug.Print fldItem.Path
                    'to get the folder name use
                    'Debug.Print fldItem.Name
                Else    'the item is a file

                    'check if the file is (docx/doc/rtf/txt) accoriding to func input
                    Select Case InStr(1, fldItem.Name, SearchedFileType, vbTextCompare)
                    Case Is > 0
                        'add those files to the dictionary
                        PathsDict.Add Key:=i, Item:=fldItem.Path
                        i = i + 1
                        'to get the parent folder path
                        'Debug.Print Left(fldItem.Path, InStrRev(fldItem.Path, fldItem.Name) - 2)
                        'to get the file name
                        'Debug.Print fldItem.Name
                        'to get the file path
                        'Debug.Print fldItem.Path
                    Case 0
                        'neglect other file types
                    End Select
                End If

                'pass the folder item as a subfolder to the same function for further processing
                If fldItem.IsFolder And LookInSubFolders Then ListItemsInFolder fldItem.Path, LookInSubFolders

            Case Else    'its a zip file
                'do nothing and bypass it
            End Select
        Next fldItem
    End With
    ListItemsInFolder = PathsDict.Items
    Set ShellAppObject = Nothing
    Set PathsDict = Nothing
End Function

Answer 2

据我所知，这是因为NameSpace的索引实际上并未定义为String。 FolderPath已经是一个字符串，并使用

"" & FolderPath & ""

不会在其周围添加引号 - 要在VBA中执行此操作，您需要

""" & FolderPath """

NameSpace真正想要的是Variant（虽然Object viewer没有拼写出来），如果你使用

With ShellAppObject.NameSpace(FolderPath)

它似乎没有得到一个。如果您在传递字符串时对字符串执行任何操作，例如

With ShellAppObject.NameSpace(FolderPath & "")

或

With ShellAppObject.NameSpace(cStr(FolderPath))

VBA似乎允许它。

或者你可以做到

Dim v As Variant
v = FolderPath
With ShellAppObject.NameSpace(v)

Answer 3

我已经测试了你的代码 - 如果文件夹不存在，我会得到同样的错误

发生这种情况时，ShellAppObject.NameSpace(FolderPath)返回的类型为Nothing，而不是ShellFolderItem或Object/Folder3

您可以使用以下检查来阻止＆＃34;使用＆＃34;阻止与＆＃34; Nothing＆＃34;对象：

If ShellAppObject.NameSpace(FolderPath) Is Nothing Then
    Debug.Print FolderPath & " does not exist! (or insufficient access permissions)"
Else
    With ShellAppObject.NameSpace(FolderPath)
        ' Your original code here...
        ' ...
    End With
End If

希望这有帮助。

Word VBA Shell对象后期绑定

3 个答案: