Vba 从第三方网站下载并保存文件

我需要使用Excel中的VBA从第三方web应用程序下载文件。 这是我目前的代码：

Dim myURL As String
myURL = "https://somewebsite/?f=13385&ver=a1df4089f0e4d11cf6b48024309fc9"
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")

WinHttpReq.Open "GET", myURL, False
WinHttpReq.Send

myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
    oStream.SaveToFile "C:\Users\xxx\abc.xlsx", 2 ' 1 = no overwrite, 2 = overwrite
    oStream.Close
End If

问题在于，此代码成功地将文件保存到目标。但在试图打开文件时，它会说文件已损坏或扩展名不正确。但是，文件大小等于我通过手动下载获得的文件

非常感谢您的帮助。

试试以下方法：

'' This function downloads a file from a given webpage named 'url' and copies it to 'copylocation' named as 'filename'.
'' It is vital to check which format does the content has. For example: xlsx, csv, txt etc. This must be determined in 'downloadformat'.
'' If an already existing file should be overwriten, then overwritefile = TRUE must be set.
''
'' Example of use: GetWebpageContent("http://www.snb.ch/n/mmr/tcoreference/Current%20Rates/Interest_Rates/source/interest_rates.xlsx",
''              "F:\public\CurrentMarketRates",
''              "SARM", "xlsx", TRUE)
''
Function GetWebpageContent(url As String, copylocation As String, filename As String, downloadformat As String, overwritefile As Boolean) As Boolean
    Dim WinHttpReq As Object, fname As String, res As Boolean
    Dim owritef As Integer
        owritef = 1
    ''do not overwrite, unless overwritefile = TRUE
    If overwritefile Then
        owritef = 2
    End If
    ''create filename and location
    res = True
    fname = "\" & filename & "_" & Year(Now) & "." & downloadformat

    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", url, False
    WinHttpReq.Send

    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile copylocation & fname, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If

    GetWebpageContent = res
End Function

试试这个：

'' This function downloads a file from a given webpage named 'url' and copies it to 'copylocation' named as 'filename'.
'' It is vital to check which format does the content has. For example: xlsx, csv, txt etc. This must be determined in 'downloadformat'.
'' If an already existing file should be overwriten, then overwritefile = TRUE must be set.
''
'' Example of use: GetWebpageContent("http://www.snb.ch/n/mmr/tcoreference/Current%20Rates/Interest_Rates/source/interest_rates.xlsx",
''              "F:\public\CurrentMarketRates",
''              "SARM", "xlsx", TRUE)
''
Function GetWebpageContent(url As String, copylocation As String, filename As String, downloadformat As String, overwritefile As Boolean) As Boolean
    Dim WinHttpReq As Object, fname As String, res As Boolean
    Dim owritef As Integer
        owritef = 1
    ''do not overwrite, unless overwritefile = TRUE
    If overwritefile Then
        owritef = 2
    End If
    ''create filename and location
    res = True
    fname = "\" & filename & "_" & Year(Now) & "." & downloadformat

    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", url, False
    WinHttpReq.Send

    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile copylocation & fname, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If

    GetWebpageContent = res
End Function

---

尝试此链接：抱歉，我很少尝试提供无法首先测试的解决方案。尝试此链接：抱歉，我很少尝试提供无法首先测试的解决方案。