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

Sub myLink()
Dim myString, myFileName As String
Dim myRangeNumber As Integer
Set fs = Application.FileSearch
myRangeNumber = Selection.Count
If myRangeNumber > 1 Then
myString = Selection(1).Text
Else
myString = Selection.Text
End If
Do Until myString = ""
With fs
.LookIn = "D:\DOG"
.SearchSubFolders = False
.Filename = myString & "*.*"
If .Execute(SortBy:=msoSortByFileName) > 0 Then
myFileName = .FoundFiles(1)
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
myFileName
End If
End With
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

複製代碼

Set fs = Application.FileSearch
....
....
With fs
.LookIn = "D:\DOG"
.SearchSubFolders = False
.Filename = myString & "*.*"
[u] If .Execute(SortBy:=msoSortByFileName) > 0 Then
myFileName = .FoundFiles(1)
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
myFileName
End If[/u]
End With

複製代碼

fs = Dir("D:\DOG" & "*.*")
Do While fs <> ""
myRangeNumber = myRangeNumber + 1
fs = Dir
Loop

複製代碼

'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

複製代碼