目錄文件列表和超鏈接沒有超鏈接權

Question

您好，我現在有點工作，我似乎無法弄清楚爲什麼我的代碼是使文本看起來像超鏈接，但實際上並沒有鏈接正確的路徑。

Sub hyperlinker() 

    Dim FSO As Object 
    Dim rsFSO As Object 
    Dim baseFolder As Object 
    Dim file As Object 
    Dim folder As Object 
    Dim row As Integer 
    Dim name As String 
    Dim path As String 


    'Get the current folder 
    Set FSO = CreateObject("scripting.filesystemobject") 
    Set baseFolder = FSO.GetFolder(ThisWorkbook.path) 
    Set FSO = Nothing 

    'Get the row at which to insert 
    row = Range("A65536").End(xlUp).row + 1 

    'Create the recordset for sorting 
    Set rsFSO = CreateObject("ADODB.Recordset") 
    With rsFSO.Fields 
    .Append "path", 200, 200 
    .Append "Name", 200, 200 
    .Append "Type", 200, 200 
    End With 
    rsFSO.Open 

    ' Traverse the entire folder tree 
    TraverseFolderTree baseFolder, baseFolder, rsFSO 
    Set baseFolder = Nothing 

    'Sort by type and name 
    rsFSO.Sort = "Type ASC, Name ASC " 
    rsFSO.MoveFirst 

    'Populate the first column of the sheet 
    While Not rsFSO.EOF 
    name = rsFSO("Name").Value 
    path = rsFSO("Path").Value 
    If (name <> ThisWorkbook.name) Then 
     ActiveSheet.Hyperlinks.Add Anchor:=Cells(row, 1), Address:=path, TextToDisplay:=name 
     row = row + 1 
    End If 
    rsFSO.MoveNext 
    Wend 

    'Close the recordset 
    rsFSO.Close 
    Set rsFSO = Nothing 

End Sub 

Private Sub TraverseFolderTree(ByVal parent As Object, ByVal node As Object, ByRef rs As Object) 

    'List all files 
    For Each file In node.Files 

    Dim name As String 
    name = Mid(file.path, Len(parent.path) + 2) 

    rs.AddNew 
    rs("Path") = path 
    rs("Name") = name 
    rs("Type") = "FILE" 
    rs.Update 
    Next 

    'List all folders 
    For Each folder In node.SubFolders 
    TraverseFolderTree parent, folder, rs 
    Next 

End Sub 

請幫助使超鏈接實際的超鏈接請。

Answer 1

謝謝@ARich

指出我在正確的方向。

希望最終的代碼！

Sub hyperlinker() 

    Dim FSO As Object 
    Dim rsFSO As Object 
    Dim baseFolder As Object 
    Dim file As Object 
    Dim folder As Object 
    Dim row As Integer 
    Dim name As String 
    Dim path As String 


    'Get the current folder 
    Set FSO = CreateObject("scripting.filesystemobject") 
    Set baseFolder = FSO.GetFolder(ThisWorkbook.path) 
    Set FSO = Nothing 

    'Get the row at which to insert 
    row = Range("A65536").End(xlUp).row + 1 

    'Create the recordset for sorting 
    Set rsFSO = CreateObject("ADODB.Recordset") 
    With rsFSO.Fields 
    .Append "path", 200, 200 
    .Append "Name", 200, 200 
    .Append "Type", 200, 200 
    End With 
    rsFSO.Open 

    ' Traverse the entire folder tree 
    TraverseFolderTree baseFolder, baseFolder, rsFSO 
    Set baseFolder = Nothing 

    'Sort by type and name 
    rsFSO.Sort = "Type ASC, Name ASC " 
    rsFSO.MoveFirst 

    'Populate the first column of the sheet 
    While Not rsFSO.EOF 
    name = rsFSO("Name").Value 
    path = rsFSO("Path").Value 
    If (name <> ThisWorkbook.name) Then 
     ActiveSheet.Hyperlinks.Add Anchor:=Cells(row, 1), Address:=path, TextToDisplay:=name 
     row = row + 1 
    End If 
    rsFSO.MoveNext 
    Wend 

    'Close the recordset 
    rsFSO.Close 
    Set rsFSO = Nothing 

End Sub 

Private Sub TraverseFolderTree(ByVal parent As Object, ByVal node As Object, ByRef rs As Object) 

    'List all files 
    For Each file In node.Files 

    Dim name As String 
    name = Mid(file.path, Len(parent.path) + 2) 

    Dim path As String 
    path = Mid(file.path, Len(parent.path) + 2) 

    rs.AddNew 
    rs("Path") = path 
    rs("Name") = name 
    rs("Type") = "FILE" 
    rs.Update 
    Next 

    'List all folders 
    For Each folder In node.SubFolders 
    TraverseFolderTree parent, folder, rs 
    Next 


End Sub 

剛剛在末尾添加了「Dim path as string」，它似乎用超鏈接勾住了路徑。