关于Office2007的Application.filesearch替代方法

葡萄枝 · 发表于 2018-7-3 21:32

在论坛里找到了一些方法，不过大多是excelhome的
https://www.veryword.com/2009/04/office2007_application-filesearch.html
这个网址里用类模块来替代，但是我用的时候发现只遍历了当前文件夹，如果要遍历当前文件夹并子文件夹，不知怎么修改代码

第一个类，命名为FileSearh：

Dim pLookIn As String Dim pSearchSubFolders As Boolean Dim pFileName As String
Public FoundFiles As New Collection

Public Property Get LookIn() As String
LookIn = pLookIn
End Property
Public Property Let LookIn(value As String)
pLookIn = value
End Property
Public Property Get SearchSubFolders() As Boolean
LookIn = pSearchSubFolders
End Property
Public Property Let SearchSubFolders(value As Boolean)
pSearchSubFolders = value
End Property
Public Property Get fileName() As String
fileName = pFileName
End Property
Public Property Let fileName(value As String)
pFileName = value
End Property
Public Function Execute() As Long

Dim ex As Long
Dim sLookIn As String
Dim sDirName As String
Dim sSubDir As String
Dim sFileName As String
Dim ff As FilesFound

Set ff = New FilesFound
sLookIn = LookIn
sDirName = Dir(sLookIn, vbDirectory)
sFileName = Dir(sLookIn & "\", vbNormal)
Do Until Len(sFileName) = 0
If sFileName Like fileName Then
ff.AddFile sLookIn, sFileName
FoundFiles.Add (ff.FoundFileFullName)
End If
sFileName = Dir
Loop
If SearchSubFolders Then
Do Until Len(sDirName) = 0
If GetAttr(sLookIn & sDirName) = vbDirectory Then
sSubDir = sDirName
Do Until Len(sFileName) = 0
If GetAttr(sDirName) = vbNormal Then
sFileName = sDirName
ff.AddFile sDirName, sFileName
FoundFiles.Add (ff)
End If
Loop
End If
sDirName = Dir
Loop
End If

Execute = FoundFiles.Count

End Function

第二个类，命名为FilesFound ：

Public FoundFileFullName As String
Public Function AddFile(path As String, fileName As String)
FoundFileFullName = path & "\" & fileName
End Function

使用：

Dim sFile as String
Dim fs As New FileSearh

With fs
.LookIn = sPath
.SearchSubFolders = True
.fileName = "*"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
sFile = .FoundFiles(i)
' your code here
Next
End If
End With

zhanglei1371 · 发表于 2018-7-3 22:41

类模块麻烦的要死。用我的两个现成的吧（别说不知道怎么用）:
Function FSO遍历()
'*------------------------------------------------------------------------------*
Dim fso As Object, b As Object, arr() As String, F
Set fso = CreateObject("scripting.filesystemobject")
With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show <> -1 Then Exit Function
      fod = .InitialFileName
End With
For Each F In fso.GetFolder(fod).Files  '目录本身的
      ReDim Preserve arr(i)
      arr(i) = F
      i = UBound(arr) + 1
Next
查找子目录 fod, arr, fso
arr = Filter(arr, ".doc", True, vbTextCompare) '仅保留doc文件
arr = Filter(arr, "*", False, vbTextCompare)
arr = Filter(arr, "$", False, vbTextCompare) '过滤掉带有$符号的文件
FSO遍历 = arr
Set fso = Nothing
End Function
Function 查找子目录(ByVal fod As String, arr, fso)
If fso.FolderExists(fod) Then
      If Len(fso.GetFolder(fod)) = 0 Then
         Debug.Print "文件夹为空"
      Else
         For Each zi In fso.GetFolder(fod).SubFolders
            For Each F In zi.Files '子目录中的
                  i = UBound(arr) + 1
                  ReDim Preserve arr(i)
                  arr(i) = F
            Next
            查找子目录 zi, arr, fso
         Next
      End If
End If
End Function

Function Dir遍历()
Dim arr() As String
With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show <> -1 Then Exit Function
      fod = .InitialFileName
End With
处理子目录 fod, arr
arr = Filter(arr, ".doc", True, vbTextCompare) '仅保留doc文件
arr = Filter(arr, "$", False, vbTextCompare) '过滤掉带有$符号的文件
Dir遍历 = arr
End Function
Sub 处理子目录(p, arr)
On Error Resume Next
Dim a As String, b() As String, c() As String
If Right(p, 1) <> "\" Then p = p + "\"
MY = Dir(p, vbDirectory Or vbHidden Or vbNormal Or vbReadOnly)
Do While MY <> ""
      If MY <> ".." And MY <> "." Then
         If (GetAttr(p + MY) And vbDirectory) = vbDirectory Then
            n = n + 1
            ReDim Preserve b(n)
            b(n - 1) = MY
         Else
         On Error Resume Next
            i = UBound(arr) + 1
         On Error GoTo 0
            ReDim Preserve arr(i)
            arr(i) = p + MY
         End If
      End If
      MY = Dir
Loop
For j = 0 To n - 1
      处理子目录 (p + b(j)), arr
Next
ReDim b(0)
End Sub