- 帖子
- 109
- 主題
- 2
- 精華
- 0
- 積分
- 114
- 點名
- 0
- 作業系統
- Win7 Win10
- 軟體版本
- Office 2019 WPS
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 深圳
- 註冊時間
- 2013-2-2
- 最後登錄
- 2024-11-6
|
4#
發表於 2016-5-4 14:36
| 只看該作者
本帖最後由 Joforn 於 2016-5-4 14:38 編輯
- 'Joforn
- Public Function FSOFileSearch(Optional ByVal SearchPath As String, _
- Optional ByVal objFolder As Object = Nothing, _
- Optional ByVal SearchName As String = vbNullString, _
- 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 If Len(SearchName) < 1 Then SearchName = "*.*|*"
- 10 Filter = Split(Replace(SearchName, "|", vbNullChar), vbNullChar)
- 11 If Len(SearchPath) Then
- 12 For I = 0 To UBound(Filter)
- 13 Filter(I) = LCase$(Trim$(Filter(I)))
- 14 If Len(Filter(I)) = 0 Then
- 15 If I = UBound(Filter) Then Exit For
- 16 For J = I + 1 To UBound(Filter)
- 17 If Len(Filter(J)) Then
- 18 Filter(I) = Filter(J)
- 19 Filter(J) = vbNullString
- 20 I = J - 1
- 21 Exit For
- 22 End If
- 23 Next J
- 24 If J > UBound(Filter) Then Exit For
- 25 End If
- 26 Next I
- 27 ReDim Preserve Filter(I - 1)
- 28 SearchName = Join(Filter, vbNullChar)
- 29 End If
-
- 30 If SearchType And 1& Then
- 31 For Each objSub In objFolder.Files
- 32 With objSub
- 33 For I = 0 To UBound(Filter)
- 34 If LCase(.Name) Like Filter(I) Then
- 35 FSOFileSearch.Add .Path
- 36 Exit For
- 37 End If
- 38 Next I
- 39 End With
- 40 Next objSub
- 41 End If
-
- 42 If SearchType And 2& Then
- 43 For Each objSub In objFolder.SubFolders
- 44 With objSub
- 45 For I = 0 To UBound(Filter)
- 46 If LCase(.Name) Like Filter(I) Then
- 47 FSOFileSearch.Add .Path
- 48 Exit For
- 49 End If
- 50 Next I
- 51 End With
- 52 Next objSub
- 53 End If
-
- 54 If SearchSub Then
- 55 For Each objSub In objFolder.SubFolders
- 56 DoEvents
- 57 Set subSearch = FSOFileSearch(, objSub, SearchName, SearchSub, SearchType)
- 58 With subSearch
- 59 For J = 1 To .Count
- 60 FSOFileSearch.Add .Item(J)
- 61 Next J
- 62 End With
- 63 Set subSearch = Nothing
- 64 Next objSub
- 65 End If
- End Function
- Public Sub myLink()
- Dim myString As String, myFileName As String
- Dim myRangeNumber As Integer
- Dim FileNames As Collection
-
- myRangeNumber = Selection.Count
- If myRangeNumber > 1 Then
- myString = Selection(1).Text
- Else
- myString = Selection.Text
- End If
-
- Do While Len(myString)
- Set FileNames = FSOFileSearch("D:\DOC\", , myString & "*.*", False)
- With FileNames
- If .Count > 0 Then ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= .Item(1)
- End With
- Set FileNames = Nothing
-
- Selection.Offset(1, 0).Activate
- myRangeNumber = Selection.Count
- If myRangeNumber > 1 Then
- myString = Selection(1).Text
- Else
- myString = Selection.Text
- End If
- Loop
- End Sub
|
|
