"Object doesn't support this option" VB代码中的错误445

Question

我正在尝试使这段代码正常工作。它给出运行时错误。有关如何修复它的任何帮助将不胜感激。我正在将这些代码放在一起以保留文件以保留记录，我并不是那么多的程序员。谢谢。

错误出在文件搜索方法中。

  Option Explicit
    Sub PopulateDirectoryList()
'dimension variables
        Dim objFSO As FileSystemObject, objFolder As Folder
Dim objFile As File, strSourceFolder As String, x As Long, i As Long
Dim wbNew As Workbook, wsNew As Worksheet
ToggleStuff False 'turn of screenupdating
Set objFSO = New FileSystemObject  'set a new object in memory
strSourceFolder = BrowseForFolder 'call up the browse for folder routine
If strSourceFolder = "" Then Exit Sub
Workbooks.Add 'create a new workbook
Set wbNew = ActiveWorkbook
Set wsNew = wbNew.Sheets(1) 'set the worksheet
wsNew.Activate
'format a header
With wsNew.Range("A1:F1")
    .Value = Array("File", "Size", "Modified Date", "Last Accessed", "Created Date", "Full Path", "Size")
    .Interior.ColorIndex = 7
    .Font.Bold = True
    .Font.Size = 12
End With
***With Application.FileSearch*** 'ERROR
    .LookIn = strSourceFolder  'look in the folder browsed to
   .FileType = msoFileTypeAllFiles 'get all files
    .SearchSubFolders = True  'search sub directories
    .Execute
 For x = 1 To .FoundFiles.Count 'for each file found, by the count (or index)
       i = x 'make the variable i = x
       If x > 60000 Then  'if there happens to be more than multipls of 60,000 files, then add a new sheet
          i = x - 60000  'set i to the right number for row placement below
          Set wsNew = wbNew.Sheets.Add(after:=Sheets(wsNew.Index))
          With wsNew.Range("A1:F1")
            .Value = Array("File", "Parent Folder", "Full Path", "Modified Date", _
                                               "Last Accessed", "Size")
            .Interior.ColorIndex = 7
            .Font.Bold = True
            .Font.Size = 12
           End With
       End If
        On Error GoTo Skip 'in the event of a permissions error
        Set objFile = objFSO.GetFile(.FoundFiles(x)) 'set the object to get it's properties
         With wsNew.Cells(1, 1) 'populate the next row with the variable data
             .Offset(i, 0) = objFile.Name
             .Offset(i, 1) = Format(objFile.Size, "0,000") & " KB"
             .Offset(i, 2) = objFile.DateLastModified
             .Offset(i, 3) = objFile.DateLastAccessed
             .Offset(i, 4) = objFile.DateCreated
             .Offset(i, 5) = objFile.Path
         End With
          ' Next objFile
Skip:
'this is in case a Permission denied error comes up or an unforeseen error
'Do nothing, just go to next file
     Next x
wsNew.Columns("A:F").AutoFit
End With
'clear the variables
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Set wsNew = Nothing
Set wbNew = Nothing
ToggleStuff True 'turn events back on
End Sub
Sub ToggleStuff(ByVal x As Boolean)
Application.ScreenUpdating = x
Application.EnableEvents = x
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    '''Code from kpuls, www.VBAExpress.com..portion of Knowledge base submission
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = ""
            If Not Left(BrowseForFolder, 1) = "" Then GoTo Invalid
        Case Else
            GoTo Invalid
        End Select
    Exit Function
Invalid:

ToggleStuff True
End Function

Answer 1

若要获得帮助，需要指定收到错误的位置。这次你很幸运，我发现了我前段时间遇到的一个错误。

错误原因

With Application.FileSearch

错误描述

运行时错误 445：对象不支持此选项

原因

自 Excel 2003>以来，该方法已被删除。实际上，在更高版本中，由于稳定性安全原因，该方法刚刚被删除。

解决方法

有人（不是我，我只是为了一个我很快就不得不做的替换而来）不接受这种更改，并开发了一些替代功能来嵌入您的 VBA 项目中并继续使用"几乎相同"的方法。通过网络有几个（通过简单地浏览 Excel 2003 之后的 FileSearch 的替代解决方案，在这里您可以找到我成功实现的解决方案;显然您需要使其适应您的代码，但如果您想继续使用当前的方法，这是要走的路。

Answer 2

，我认为大多数应用程序和一些非常古老的游戏都有这个错误的解决方案：运行时 445，在 Windows 8 或 10 架构中。 功劳归于Microsoft，他们在右键单击要打开的应用程序时在打开菜单中包含一个功能，有"兼容性故障排除"只需运行它。它帮助了我，所以也可能对你有帮助。这是因为在非常旧的 VB 版本中构建的软件或游戏，今天的操作系统不支持这些版本。