VBA 从超链接打开文件

Question

不知是否有人可以帮助我。

在此过程中得到一些帮助，我使用下面的代码执行以下操作：

从给定路径提取文件，
正在将文件名插入列 C,
D 和

B 列中每一行的超链接，用户选择将其带到 'Save As Dialog' 允许用户保存文件。

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

当用户单击超链接时，这是运行的 'Follow Hyperlink' 代码，允许用户保存文件。

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

    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，我想要用户能够查看文件而不是直接被带到 'Save As Dialog'.

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

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

非常感谢和亲切的问候

克里斯

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

VBA 从超链接打开文件

VBA Open File From Hyperlink

excel

vba

excel-2013