2个回答
展开全部
Sub 设置超链接()
Dim strSrcPath$, lngRow&, objFso As Object, objFile As Object
Set objFso = CreateObject("Scripting.FileSystemObject")
Dim objFldlg As FileDialog
Set objFldlg = Application.FileDialog(msoFileDialogFolderPicker)
With objFldlg
.AllowMultiSelect = False
.Title = "请选择需要建立超链接的文件夹"
.InitialFileName = ThisWorkbook.Path
If .Show = -1 Then
Range("b2").Resize(10000).ClearContents
lngRow = 1
strSrcPath = .SelectedItems(1) & IIf(Right(.SelectedItems(1), 1) = "\", "", "\")
For Each objFile In objFso.GetFolder(strSrcPath).Files
lngRow = lngRow + 1
ActiveSheet.Hyperlinks.Add Anchor:=Cells(lngRow, 2), _
Address:=strSrcPath & objFile.Name, SubAddress:="", _
ScreenTip:=objFile.Name, TextToDisplay:=objFile.Name
Next objFile
End If
End With
Set objFldlg = Nothing
Set objFile = Nothing
Set objFso = Nothing
CreateObject("Wscript.Shell").Popup "Done...", 2, "^o^", vbOKOnly
End Sub
Dim strSrcPath$, lngRow&, objFso As Object, objFile As Object
Set objFso = CreateObject("Scripting.FileSystemObject")
Dim objFldlg As FileDialog
Set objFldlg = Application.FileDialog(msoFileDialogFolderPicker)
With objFldlg
.AllowMultiSelect = False
.Title = "请选择需要建立超链接的文件夹"
.InitialFileName = ThisWorkbook.Path
If .Show = -1 Then
Range("b2").Resize(10000).ClearContents
lngRow = 1
strSrcPath = .SelectedItems(1) & IIf(Right(.SelectedItems(1), 1) = "\", "", "\")
For Each objFile In objFso.GetFolder(strSrcPath).Files
lngRow = lngRow + 1
ActiveSheet.Hyperlinks.Add Anchor:=Cells(lngRow, 2), _
Address:=strSrcPath & objFile.Name, SubAddress:="", _
ScreenTip:=objFile.Name, TextToDisplay:=objFile.Name
Next objFile
End If
End With
Set objFldlg = Nothing
Set objFile = Nothing
Set objFso = Nothing
CreateObject("Wscript.Shell").Popup "Done...", 2, "^o^", vbOKOnly
End Sub
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询