單擊 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