单击 excel 中的超链接，将文件从 .network 驱动器本地服务器下载到文件夹

Question

我有一个 excel，其中有大约 30K 个超链接指向存储所有文件的网络驱动器位置。 我正在尝试创建一个宏，当我单击超链接时，它会将文件下载到像“下载”这样的文件夹，而现在它只是在 IE 中查看文件。

对宏不太了解，但尝试使用 shell app.browseforfolder、FileCopy 和 URLDownloadToFile 但仍然出现错误。还尝试使用 Selection 下载选定的单元格超链接但没有骰子。

样本 excel 文件在这里： https://filebin.net/06n8hp1wm8y69oqw

网络驱动器链接如下：

\\10.111.11.30\账户\EP-D365\39156.jpg

\\10.111.11.30\账户\EP-D365\39157.jpg

\\10.111.11.30\账户\EP-D365\39158.msg

我设法从在线资源中整理了以下代码，但无法正常工作，因为它是从 inte.net 和 not.network 驱动器本地服务器下载的：

Sub DownloadFile()
Dim WinHttpReq As Object
Dim oStream As Object
Dim myURL As String
Dim LocalFilePath As String
''For Each hlink In ThisWorkbook.Sheets("Main").Hyperlinks
myURL = "\\10.111.11.30\Accounts\EP-D365\39156.jpg"
LocalFilePath = "C:\Users"

Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "", ""
WinHttpReq.send

If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
    oStream.SaveToFile LocalFilePath, 2
    oStream.Close
End If
''Next
End Sub

任何帮助表示赞赏。谢谢。

Answer 1

您可以使用FileCopy从文件系统复制文件 - 使用 UNC 路径。 我认为您的问题来自目的地 - 运行时错误 75 是路径/文件访问错误，这通常意味着无法写入文件。

我不是 100% 确定FileCopy的所有细节，但我认为你还必须提供目标的文件名 - 它不同于命令提示符下的copy 。 如果您只写入目标文件夹，则会收到错误 75，因为FileCopy试图用文件替换目标文件夹——这当然不起作用。

以下代码将从 Http 和文件系统复制这两个文件。 我通过检查路径是否包含“斜杠”或“反斜杠”（Mac 用户将需要找到不同的尝试）来快速和肮脏地完成它。 文件名从源中提取并粘贴到目标文件夹。

一个小建议：不要对用户路径进行硬编码，您可以改用environ("userprofile") 。

还有一点：如果目标文件夹不存在，代码将失败。

Sub test()

    Const source = "\\10.111.11.30\Accounts\EP-D365\39156.jpg"
    Const url = "https://i.stack.imgur.com/WyPLd.png"

    CopyFile source, Environ("TEMP")
    CopyFile url, Environ("TEMP")

End Sub


Sub CopyFile(source As String, destPath As String)

    If InStr(source, "/") > 0 Then
        DownloadFile source, Environ("TEMP")
    Else
        Dim filename As String, p As Integer
        p = InStrRev(source, "\")
        filename = Mid(source, p + 1)
        FileCopy source, destPath & "\" & filename
    End If
End Sub

Sub DownloadFile(url As String, destPath As String)
    
    Dim WinHttpReq As Object
    Dim oStream As Object

    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", url, False, "", ""
    WinHttpReq.send
    
    Dim filename As String, p As Integer
    p = InStrRev(url, "/")
    filename = Mid(url, p + 1)
    
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile destPath & "\" & filename, 2
        oStream.Close
    End If
End Sub