VBA 从超链接打开文件

Question

我想知道是否有人可以帮助我。

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

• 从给定路径中提取文件，
• 将文件名插入C列，
• D 列和
列的文件路径

• B 列中每一行上的超链接，用户可以选择将其带到“另存为对话框”，以便用户保存文件。 p>

  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

代码运行良好，但我希望对其稍作更改，但到目前为止我尝试过的方法都没有奏效。

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

我有点不知所措，正如我所说，我所做的改变没有奏效。

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

非常感谢和亲切的问候

克里斯

Answer 1

检查扩展名，询问，将文件传递给 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