VBA打开文件从超链接

Question

我不知道是否有人也许能帮助我请。

随着沿途一些帮助，我使用下面的代码来执行以下操作：从给定路径

• 解压文件，
• 插入文件名到C列，
• 文件路径为柱d，和

• 在列A上的每一行的超链接乙，其用户选择他们去到“另存为对话框”允许用户保存文件。

  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