VBS从链接保存文件

Question

我想知道是否有人能帮我。

我想在我试图编写的脚本中使用这个解决方案，但我有点不确定如何做出需要做出的更改。

你会在解决方案中看到，打开的文件类型是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

非常感谢

Chris

Answer 1

Miguel提供了一个出色的解决方案，在最初的测试中似乎100%有效。但正如你从帖子末尾的评论中看到的那样，当用户取消操作时，出现了一些问题，所以我在这个链接上又发了一篇帖子，解决了问题。非常感谢和问候。Chris

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:DocumentsSomeWordTemplate.docx", ReadOnly:=True)
'DO STUFF if it's an authorized file. Then Save file.
With wDoc
.ActiveDocument.SaveAs Filename:="C:DocumentsNewWordDocumentFromTemplate.docx"
End With
wApp.DisplayAlerts = True
End if
End If

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

编辑：

2：添加的评论

嗨，IRHM，

我想你想要这样的东西："Worksheet_FollowHyperlink"是一个点击事件，每次您点击工作表中的超链接时都会发生。您可以在此处找到更多

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

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

您只需要将代码粘贴到工作表代码中即可。你应该很乐意去。