麻辣家族討論版版 - Powered by Discuz! Board

Option Explicit
Option Compare Text
#If VBA7 Then
Private Declare PtrSafe Function PathRemoveBackslashW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function PathRemoveExtension Lib "shlwapi.dll" Alias "PathRemoveExtensionW" (ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function PathStripPath Lib "shlwapi.dll" Alias "PathStripPathW" (ByVal pszPath As LongPtr) As Long
#Else
Private Declare Function PathRemoveBackslashW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
Private Declare Function PathRemoveExtension Lib "shlwapi.dll" Alias "PathRemoveExtensionW" (ByVal pszPath As Long) As Long
Private Declare Function PathStripPath Lib "shlwapi.dll" Alias "PathStripPathW" (ByVal pszPath As Long) As Long
#End If
'使用FSO搜索文件或是文件夹
Public Function FSOFileSearch(Optional ByVal SearchPath As String, _
Optional ByVal objFolder As Object = Nothing, _
Optional ByVal SearchName As String = "*.*", _
Optional ByVal SearchSub As Boolean = True, _
Optional ByVal SearchType As Long = 1) As Collection
Dim FSO As Object
Dim Filter() As String
Dim subSearch As Collection
Dim I As Long, J As Long
Dim objSub As Object
1 Set FSOFileSearch = New Collection
2 If objFolder Is Nothing Then
3 If Len(SearchPath) = 0 Then Exit Function
4 Set FSO = CreateObject("Scripting.FileSystemObject")
5 Set objFolder = FSO.GetFolder(SearchPath)
6 Set FSO = Nothing
7 If objFolder Is Nothing Then Exit Function
8 End If
9 Filter = Split(Replace(SearchName, "|", vbNullChar), vbNullChar)
10 If Len(SearchPath) Then
11 For I = 0 To UBound(Filter)
12 Filter(I) = LCase$(Trim$(Filter(I)))
13 If Len(Filter(I)) = 0 Then
14 If I = UBound(Filter) Then Exit For
15 For J = I + 1 To UBound(Filter)
16 If Len(Filter(J)) Then
17 Filter(I) = Filter(J)
18 Filter(J) = vbNullString
19 I = J - 1
20 Exit For
21 End If
22 Next J
23 If J > UBound(Filter) Then Exit For
24 End If
25 Next I
26 ReDim Preserve Filter(I - 1)
27 SearchName = Join(Filter, vbNullChar)
28 End If
29 If SearchType And 1& Then
30 For Each objSub In objFolder.Files
31 With objSub
32 For I = 0 To UBound(Filter)
33 If LCase(.Name) Like Filter(I) Then
34 FSOFileSearch.Add .Path
35 Exit For
36 End If
37 Next I
38 End With
39 Next objSub
40 End If
41 If SearchType And 2& Then
42 For Each objSub In objFolder.SubFolders
43 With objSub
44 For I = 0 To UBound(Filter)
45 If LCase(.Name) Like Filter(I) Then
46 FSOFileSearch.Add .Path
47 Exit For
48 End If
49 Next I
50 End With
51 Next objSub
52 End If
53 If SearchSub Then
54 For Each objSub In objFolder.SubFolders
55 DoEvents
56 Set subSearch = FSOFileSearch(, objSub, SearchName, SearchSub, SearchType)
57 With subSearch
58 For J = 1 To .Count
59 FSOFileSearch.Add .Item(J)
60 Next J
61 End With
62 Set subSearch = Nothing
63 Next objSub
64 End If
End Function
Public Function ExtractFileName(ByVal strPath As String, Optional ByVal ExtensionReturn As Boolean = True) As String
Dim I As Long, J As Long
strPath = strPath & String(10, vbNullChar)
J = InStr(strPath, vbNullChar)
PathRemoveBackslashW StrPtr(strPath)
If InStr(strPath, vbNullChar) <> J Then ExtensionReturn = True
PathStripPath StrPtr(strPath)
If Not ExtensionReturn Then PathRemoveExtension StrPtr(strPath)
I = InStr(strPath, vbNullChar)
If I > 0 Then strPath = Left$(strPath, I - 1)
ExtractFileName = strPath
End Function
Sub TestOpenFiles()
Dim I As Long
Dim Search As Collection
Dim FileName As String
'搜索当前文件所在目录中及其所有子目录下的.XLSX、.XLSM、.XLS、.XLSB文件
Set Search = FSOFileSearch("\\Pcbfs02\c740\檢核表\", , "*.XLS[XMB]|*.XLS",False)
For I = 1 To Search.Count
FileName = ExtractFileName(Search(I), False)
If FileName Like ((Sheet1.Range("E3").Value) & "*") Then Workbooks.Open FileName:=Search(I)
Next I
End Sub

複製代碼