VBA从超链接打开文件

不知是否有人能帮助我

在一些帮助下，我将使用下面的代码执行以下操作：

• 从给定路径提取文件
• 将文件名插入列C
• 将文件路径插入列D，然后
• 列B中每一行上的超链接，用户选择该超链接将其带到的“另存为对话框”，允许用户保存文件

  Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
  
  Dim fName As String
  Dim Lastrow As Long
  
  On Error Resume Next
  For Each FileItem In SourceFolder.Files
  ' display file properties
      Cells(iRow, 3).Formula = FileItem.Name
      Cells(iRow, 4).Formula = FileItem.Path
      iRow = iRow + 1 ' next row number
  ''''''''
  '' As the progress bar is set for 0 to 100, treat
  '' the progress as a percentage when calculating
  ''''''''
      frm.prgStatus.Value = (xCur / xMax) * 100
  '' Add 1 to xCur ready for next file
      xCur = xCur + 1
      Next FileItem
  
      Range("C10").CurrentRegion.Select
      Selection.Sort Key1:=Range("C10"), Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal
  
      With ActiveSheet
          Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
          Lastrow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      End With
  
      If IncludeSubfolders Then
          For Each SubFolder In SourceFolder.SubFolders
              ListFilesInFolder SubFolder, True
              Next SubFolder
          End If
          Set FileItem = Nothing
          Set SourceFolder = Nothing
          Set FSO = Nothing
  
          For iRow = 10 To Lastrow
              Cells(iRow, 2).Formula = iRow - 9
              Cells(iRow, 4).Formula = FileItem.Path
              ActiveSheet.Hyperlinks.Add Anchor:=Cells(iRow, 2), Address:="", _
              ScreenTip:=CStr(iRow - 9)
          Next
      End Sub
  

当用户单击超链接时，这是允许用户保存文件的“跟随超链接”代码

Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)

Dim fName As String
Dim Lastrow As Long

On Error Resume Next
For Each FileItem In SourceFolder.Files
' display file properties
    Cells(iRow, 3).Formula = FileItem.Name
    Cells(iRow, 4).Formula = FileItem.Path
    iRow = iRow + 1 ' next row number
''''''''
'' As the progress bar is set for 0 to 100, treat
'' the progress as a percentage when calculating
''''''''
    frm.prgStatus.Value = (xCur / xMax) * 100
'' Add 1 to xCur ready for next file
    xCur = xCur + 1
    Next FileItem

    Range("C10").CurrentRegion.Select
    Selection.Sort Key1:=Range("C10"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal

    With ActiveSheet
        Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        Lastrow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With

    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder, True
            Next SubFolder
        End If
        Set FileItem = Nothing
        Set SourceFolder = Nothing
        Set FSO = Nothing

        For iRow = 10 To Lastrow
            Cells(iRow, 2).Formula = iRow - 9
            Cells(iRow, 4).Formula = FileItem.Path
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(iRow, 2), Address:="", _
            ScreenTip:=CStr(iRow - 9)
        Next
    End Sub

*****更新代码*****

    Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)

    Dim FSO
    Dim sFile As String
    Dim sDFolder As String
    Dim thiswb As Workbook ', wb As Workbook

    On Error GoTo CleanExit:

'Disable events so the user doesn't see the codes selection
    Application.EnableEvents = False

'Define workbooks so we don't lose scope while selecting sFile(thisworkbook = workbook were the code is located).
    Set thiswb = ThisWorkbook
'Set wb = ActiveWorkbook ' This line was commented out because we no longer need to cope with 2 excel workbooks open at the same time.
'Target.Range.Value is the selection of the Hyperlink Path. Due to the address of the Hyperlink being "" we just assign the value to a
'temporary variable which is not used so the Click on event is still triggers
    temp = Target.Range.Value
'Activate the wb, and attribute the File.Path located 1 column left of the Hyperlink/ActiveCell
    thiswb.Activate
    sFile = Cells(ActiveCell.Row, ActiveCell.Column + 2).Value

    If UCase$(Mid$(sFile, InStrRev(sFile, ".") + 1)) = "DOCX" Then

    Application.EnableEvents = True
        Select Case MsgBox("Do you wish to view the file before saving?", vbYesNoCancel Or vbQuestion, "Save or View?")
            Case vbCancel: Exit Sub
            Case vbYes:
                With CreateObject("Word.Application")
                    .Visible = True
                    .Documents.Open sFile
                    .Activate
                End With
                Exit Sub
        End Select
    End If

'Declare a variable as a FileDialog Object
    Dim fldr As FileDialog
'Create a FileDialog object as a File Picker dialog box.
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
'Allow only single selection on Folders
    fldr.AllowMultiSelect = False
'Show Folder picker dialog box to user and wait for user action
    fldr.Show

'Did the user cancel?
    If fldr.SelectedItems.Count > 0 Then
'Add the end slash of the path selected in the dialog box for the copy operation
        sDFolder = fldr.SelectedItems(1) & "\"
'FSO System object to copy the file
        Set FSO = CreateObject("Scripting.FileSystemObject")
' Copy File from (source = sFile), destination , (Overwrite True = replace file with the same name)
        FSO.CopyFile (sFile), sDFolder, True
        MsgBox "File Saved!"
    Else
'Do anything you need to do if you didn't get a filename.
    MsgBox "You choose not to save the file!"

    End If
' Check if there's multiple excel workbooks open and close workbook that is not needed
' section commented out because the Hyperlinks no longer Open the selected file
' If Not thiswb.Name = wb.Name Then
'     wb.Close
' End If
CleanExit:
    If Err.Number <> 0 Then
        MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
    End If

    Application.EnableEvents = True
End Sub

Private子工作表\u FollowHyperlink（ByVal目标作为超链接）
模糊FSO
将文件设置为字符串
将文件夹设置为字符串
将此wb设置为工作簿'，将wb设置为工作簿
转到CleanExit时出错：
'禁用事件，以便用户看不到选择的代码
Application.EnableEvents=False
'定义工作簿，以便在选择sFile时不会丢失作用域（代码所在的thisworkbook=工作簿）。
设置thiswb=thishworkbook
“Set wb=ActiveWorkbook”此行已被注释掉，因为我们不再需要处理同时打开的两个excel工作簿。
'Target.Range.Value是超链接路径的选择。由于超链接的地址为“”，我们只将该值分配给
'未使用的临时变量，因此仍会触发单击事件
温度=目标范围值
'激活wb，并将位于Hyperlink/ActiveCell左侧1列的File.Path设置为属性
这个WB。激活
sFile=Cells（ActiveCell.Row，ActiveCell.Column+2）.Value
如果UCase$（Mid$（sFile，InStrRev（sFile，“.”+1））=“DOCX”，则
Application.EnableEvents=True
选择Case MsgBox（“是否希望在保存前查看文件？”、vbYesNoCancel或vbQuestion“保存或查看？”）
案例vbCancel：退出子系统
案例：是：
使用CreateObject（“Word.Application”）
.Visible=True
.Documents.Open文件
.激活
以
出口接头
结束选择
如果结束
'将变量声明为FileDialog对象
Dim fldr As FILE对话框
'将FileDialog对象创建为文件选择器对话框。
设置fldr=Application.FileDialog（msoFileDialogFolderPicker）
'只允许对文件夹进行单个选择
fldr.AllowMultiSelect=False
'向用户显示文件夹选择器对话框并等待用户操作
飞行表演
'用户取消了吗？
如果fldr.SelectedItems.Count>0，则
'添加在对话框中为复制操作选择的路径的结束斜杠
sDFolder=fldr.SelectedItems（1）和“\”
'要复制文件的FSO系统对象
设置FSO=CreateObject（“Scripting.FileSystemObject”）
'从（source=sFile）复制文件，目标，（Overwrite True=replace File with the same name）
FSO.CopyFile（sFile），sDFolder，True
MsgBox“文件已保存！”
其他的
'如果没有文件名，请执行任何需要执行的操作。
MsgBox“您选择不保存文件！”
如果结束
'检查是否有多个excel工作簿不需要打开和关闭工作簿
'部分已注释掉，因为超链接不再打开所选文件
'如果不是thiswb.Name=wb.Name，则
“wb，结束
"完"
清洁出口：
如果错误号为0，则
MsgBox“错误：”&错误编号&vbCrLf&错误描述
如果结束
Application.EnableEvents=True
端接头

代码运行得很好，但我希望对此进行一点修改，而到目前为止我所做的尝试没有奏效

我想做的是通过从列d中的路径提取文件扩展名来改变这一点，如果扩展名是.docx，我希望用户能够查看文件，而不是直接进入“另存为对话框”

我有点力不从心，正如我所说，我所做的改变没有奏效

我只是想知道是否有人可以看看这一点，并提供一些指导，我可以如何实现这一点

非常感谢和亲切的问候

---

克里斯

检查分机，询问，将文件传递给Word：

sFile = Cells(ActiveCell.Row, ActiveCell.Column + 2).Value

If UCase$(Mid$(sFile, InStrRev(sFile, ".") + 1)) = "DOCX" Then
    Select Case MsgBox("View before saving?", vbYesNoCancel Or vbQuestion, "Save or View?")
        Case vbCancel: Exit Sub
        Case vbYes:
            With CreateObject("Word.Application")
                .Visible = True
                .Documents.Open sFile
                .Activate
            End With
            Exit Sub
    End Select
End If

---

你为什么不编写代码，用你想要的文件名保存每个文件，而不是让别人手动执行呢？嗨@TobyAllen，非常感谢你抽出时间回复我的帖子。允许用户手动保存文件的想法是，他们可以在本地计算机上浏览希望显示的文件夹。亲切的问候。嗨@Alex K。感谢您抽出时间回复我的帖子，并整理代码。请原谅，但你能告诉我，我将在哪里把它合并到我现有的代码中。非常感谢和亲切的问候。Christ上面的第一行来自您的代码，因此在您的

sFile=…

嗨，Alex K.这非常有效。非常感谢您的帮助，我非常感谢。非常感谢和亲切的问候。ChrisHi@Alex K.很抱歉用这个agian给你添麻烦，但是我一直在用你提供的代码继续测试，我遇到了一个问题。如果用户选择一个“.docx”文件并查看该文件，则该过程可以正常工作，但如果用户随后尝试选择列表中的任何其他超链接，无论它们是否为“.docx”文件类型，超链接将被停用。你知道我怎样才能克服这个困难吗。致以亲切的问候和衷心的感谢。chrise在退出或完全删除Application.EnableEvents调用之前，请确保您的Application.EnableEvents=True