Question

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

我想在我试图整理的脚本中使用this解决方案，但我对如何进行需要进行更改有些不确定。

您将在解决方案中看到打开的文件类型是Excel，实际上它已保存。但我想打开并保存的文件是.docx和.dat（由Dragon软件使用）文件的混合。

有人可以告诉我，有没有办法可以修改代码，以便打开并将文件保存在Excel工作簿以外的文件类型中。

这个问题背后的原因是因为我目前正在使用一个脚本，该脚本在给定文件夹的Excel电子表格中创建文件列表。对于检索到的每个文件，都有一个超链接，我想添加一个超级功能，用户可以复制该文件并将其保存到他们选择的位置。

为了帮助这是我用来创建文件列表的代码。

Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
    Dim LastRow As Long
    Dim fName As String
    On Error Resume Next

    For Each FileItem In SourceFolder.Files
        ' display file properties
        Cells(iRow, 3).Formula = iRow - 12
        Cells(iRow, 4).Formula = FileItem.Name
        Cells(iRow, 5).Formula = FileItem.Path
        Cells(iRow, 6).Select
        Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
        FileItem.Path, TextToDisplay:="Click Here to Open"
        iRow = iRow + 1 ' next row number

        With ActiveSheet
        LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With

For Each Cell In Range("C13:F" & LastRow) ''change range accordingly
    If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
        Cell.Interior.Color = RGB(232, 232, 232) ''color to preference
    Else
        Cell.Interior.Color = RGB(141, 180, 226) 'color to preference or remove
    End If
Next Cell

    Next FileItem


    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
End Sub

非常感谢和亲切的问候

克里斯

Answer 1

Miguel提供了一个出色的解决方案，在初始测试中似乎100％工作。但正如您将从帖子末尾的评论中看到的那样，当用户取消操作时会出现一些问题，因此我在此link处发布了另一篇文章，其中解决了问题。非常感谢和亲切的问候。克里斯

Answer 2

下面的代码显示了如何检索文件的扩展名，定义具有“允许”扩展名的数组，并将文件的扩展名与数组匹配。

这是文件操作的大纲，您只需根据需要定制

Dim MinExtensionX
Dim Arr() As Variant
Dim lngLoc As Variant


'Retrieve extension of file

  MinExtensionX = Mid(MyFile.Name, InStrRev(MyFile.Name, ".") + 1)

  Arr = Array("xls", "xlsx", "docx", "dat") 'define which extensions you want to allow

On Error Resume Next

  lngLoc = Application.WorksheetFunction.Match(MinExtensionX, Arr(), 0)

If Not IsEmpty(lngLoc) Then '

  'check which kind of extension you are working with and create proper obj manipulation 
  If MinExtensionX = "docx" then

     Set wApp = CreateObject("Word.Application")
     wApp.DisplayAlerts = False
     Set wDoc = wApp.Documents.Open (Filename:="C:\Documents\SomeWordTemplate.docx", ReadOnly:=True)

     'DO STUFF if it's an authorized file. Then Save file.

     With wDoc

          .ActiveDocument.SaveAs Filename:="C:\Documents\NewWordDocumentFromTemplate.docx"

     End With

     wApp.DisplayAlerts = True

     End if
End If

对于文件。但它有点复杂，特别是如果您需要打开/处理文件中的数据，但this可能会帮助您。

编辑：

2：添加评论

你好IRHM，

我想你想要这样的东西： 'Worksheet_FollowHyperlink'是每次单击工作表中的超链接时发生的单击事件，您可以找到更多here

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)

'disable events so the user doesn't see the codes selection
Application.EnableEvents = False

    Dim FSO
    Dim sFile As String
    Dim sDFolder As String
    Dim thiswb As Workbook ', wb As Workbook

    '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 - 1).Value

    '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

    '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

    ' 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
Application.EnableEvents = True

End Sub

上面的代码单击超链接时会触发，它会提示文件夹选择窗口。

您只需将代码粘贴到Worksheet代码中即可。你应该好好去。

VBS从链接保存文件

2 个答案: