- 帖子
- 109
- 主題
- 2
- 精華
- 0
- 積分
- 114
- 點名
- 0
- 作業系統
- Win7 Win10
- 軟體版本
- Office 2019 WPS
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 深圳
- 註冊時間
- 2013-2-2
- 最後登錄
- 2024-11-6
|
2#
發表於 2016-12-23 21:55
| 只看該作者
本帖最後由 Joforn 於 2016-12-23 21:58 編輯
- 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
|
|
發表於 2016-12-24 08:34
| 