VBA Open File From Hyperlink

Question

Интересно, может ли кто-нибудь помочь мне.

С некоторой помощью по пути, я использую ниже код для выполнения следующего:

• Извлечение файлов из заданного пути,
• вставки файла в столбец C,
• Путь к файлу в колонке D и

• гиперссылки на каждой строке в столбце в, которой пользователь выбирает их до 'Сохранить как диалог', позволяющий пользователю сохранить файл.

  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 
  

Когда пользователь щелкает на гиперссылке, это код «Открывать 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, я хотел бы, чтобы пользователь мог просматривать файл довольно чем на прямой диалог «Сохранить как».

Я немного из глубины и, как я уже сказал, изменения, которые я сделал, не сработали.

Я просто задавался вопросом, может ли кто-нибудь взглянуть на это, пожалуйста, и предложить некоторые рекомендации о том, как я могу добиться этого.

Большое спасибо и добрые пожелания

Chris

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