Question

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

在此过程中提供了一些帮助，我正在使用以下代码执行以下操作：

从给定路径中提取文件
将文件名插入 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

当用户点击超链接时，这是“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，我希望用户能够查看文件而不是直接进入“另存为对话框”。

我有点超出我的深度，因为我说我所做的改变没有奏效。

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

非常感谢和亲切的问候

克里斯

Answer 1

检查扩展名，询问，将文件传递给Word：

<img src="test.png" style="display:none">

VBA从超链接打开文件

1 个答案: