从Excel 2019中的URL下载文件(在Excel 2007上有效) [英] Download file from url in Excel 2019 (it works on Excel 2007)

问题描述

我有一个代码，可从需要证书的网站下载CSV文件.感谢这个网站，我得到了一个代码，我可以适应我的需求.我相关的代码部分是:

I got a code to download a CSV file from a website that requires credentials. I got a code thanks to this website and I could adapted to my needs. My relevant part of code is:

Option Explicit

Private Declare Function URLDownloadToFileA Lib "urlmon" _
    (ByVal pCaller As Long, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long

Private Function DownloadUrlFile(URL As String, LocalFilename As String) As Boolean
    Dim RetVal As Long
    RetVal = URLDownloadToFileA(0, URL, LocalFilename, 0, 0)
    If RetVal = 0 Then DownloadUrlFile = True
End Function

Sub DESCARGAR_CSV_DATOS()

Dim EstaURL As String
Dim EsteCSV As String

EstaURL = "https://user:[e-mail]/export/targetfile.csv"
EsteCSV = "MyCSV " & Format(Date, "dd-mm-yyyy") & ".csv"

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    DownloadUrlFile EstaURL, _
        ThisWorkbook.Path & "\" & EsteCSV

    DoEvents

    Workbooks.Open ThisWorkbook.Path & "\" & EsteCSV, , True, , , , , , , , , , , True

    'rest is just doing operations and calculations inside workbook

End Sub

对不起，但我无法提供真实的网址.无论如何，此代码自2019年9月以来一直运行良好.并且仍然每天都能正常运行.

Sorry but I cannot provide the real url. Anyways, this code has been working perfectly since September 2019. And it still works perfectly every day.

执行此代码的计算机均为Windows 7和Excel 2007和64位.他们都没有失败.

The computers that execute this code are all of them Windows 7 and Excel 2007 and 64 bits. None of them fail.

但是现在，此任务将外包给另一个办公室.在那里，计算机是Excel 2019，Windows 10和64位.

But now, this task is going to be outsourced to another office. There, the computers are Excel 2019, Windows 10 and 64 bits.

并且代码在那里不起作用.它不会出现任何错误，但是函数DownloadUrlFile不会在Excel 2019 + W10上下载任何文件

And the code does not work there. It does not arise any error, but the function DownloadUrlFile does not download any file on Excel 2019 + W10

因此，要恢复，Excel 2007 + Windows 7可以完美运行(今天经过测试). Excel 2019 + Windows 10不起作用(屏幕上没有错误).

So to resume, Excel 2007 + Windows 7 works perfectly (tested today). Excel 2019 + Windows 10 does not work (no errors on screen).

我已尝试解决的问题:

1. 我已检查urlmon.dll中是否存在文件urlmon.dll，并且确实存在
2. 我尝试使用PtrSafe
声明函数URLDownloadToFileA
3. 如果我使用Excel 2019 + W10在PC上的Chrome中手动键入URL，则文件已正确下载，因此URL正常.

1. I've checked that file urlmon.dll exists in system32 and it does
2. I've tried declaring the function URLDownloadToFileA using PtrSafe
3. If I manually type the url in Chrome in the PC with Excel 2019 + W10, the file is downloaded properly, so the URL is ok.

这些都没有解决我的问题.我很确定该解决方案非常简单，因为该代码在Excel 2007中可以完美运行，但是我找不到在这里缺少的内容.

None of this solved my problem. I'm pretty sure the solution it's really easy, because the code works perfectly in Excel 2007, but I can't find what I'm missing here.

我想获得一个在任何情况下都可以使用的代码，但是我也接受仅在Excel 2019和Windows 10中可以使用的解决方案.

I would like to get a code that works in any case, but I would accept also a solution that works only in Excel 2019 and Windows 10 if it's the only way.

希望有人可以对此有所启发.预先感谢.

Hope somebody can throw some light about this. Thanks in advance.

更新:还在这篇文章中尝试了该解决方案，但还是没有解决.

UPDATE: Tried also the solution in this post but still nothing.

更新2:另外，还使用Excel 2010测试了此处发布的代码(Excel 2007)，它可以完美运行.

UPDATE 2: Also, tested the code posted here (Excel 2007) with Excel 2010 and it works perfectly.

更新3::变量RetVal存储下载结果.我知道一些值:

UPDATE 3: The variable RetVal stores the result of the download. I know some values:

' Returns 0 if success, error code if not.
' Error codes:
' -2146697210 "file not found".
' -2146697211 "domain not found".
' -2147467260 "transfer aborted".

但是在我的情况下，它返回-2147221020.那会是什么?

But in my case, it returns -2147221020. What could that be?

更新4:嗯，这很奇怪.我尝试使用相同的代码从公共网站下载不同的文件，并且可以在Excel 2019 + W10中使用. 我编写了一个新的简单代码，如下所示:

UPDATE 4: Well, this is just weird. I've tried same code to download a different file from a public website, and it works in Excel 2019 + W10. I made a new easy code like this:

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As LongPtr, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As LongPtr, _
        ByVal lpfnCB As LongPtr _
      ) As Long
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long _
      ) As Long
#End If

Sub Descarga()
Dim EstaURL As String
Dim EsteCSV As String

EstaURL = privateone 'can't be shared, sorry
EsteCSV = "CSV Datos " & Format(Date, "dd-mm-yyyy") & ".csv"

    On Error GoTo Errores
    URLDownloadToFile 0, "https://tutorialesexcel.com/wp-content/uploads/2018/10/funciones.xlsm", ThisWorkbook.Path & "\" & EsteCSV, 0, 0
    URLDownloadToFile 0, EstaURL, ThisWorkbook.Path & "\" & EsteCSV, 0, 0
    Exit Sub
Errores:
    'Si es un bucle lo mejor sería no mostrar ningún mensaje
    MsgBox "Not downloaded", vbCritical, "Errores"
End Sub

显示URLDownloadToFile 0, "https://tutorialesexcel.com/wp-content/uploads/2018/10/funciones.xlsm", ThisWorkbook.Path & "\" & EsteCSV, 0,的行可以正常运行，并下放文件.

The line that says URLDownloadToFile 0, "https://tutorialesexcel.com/wp-content/uploads/2018/10/funciones.xlsm", ThisWorkbook.Path & "\" & EsteCSV, 0, works perfect and downloas the file.

URLDownloadToFile 0, EstaURL, ThisWorkbook.Path & "\" & EsteCSV, 0, 0行不起作用.

因此再次测试了完全相同的代码，但在Excel 2007上，并且两者均正常工作

So tested again exactly same code but on Excel 2007 and both of them work

为什么第一次下载有效，而第二个下载却不能在Excel 2019 + W10上运行，而两者都可以在Excel 2007 + W7上运行?

Why the first download works and the second one does not on Excel 2019 + W10 but both of them work on Excel 2007+W7?

更新5:该URL是私有的，因为它包含用户名和密码，但它是这样的:

UPDATE 5: The URL is private, because it contains username and password, but it's like this:

https://user:[e-mail]/export/target%20file.csv

由于@ Stachu，URL无法在任何PC上的Internet Explorer上手动工作(我是说，在资源管理器导航栏中进行复制/粘贴).该网址可在所有PC的Google Chrome浏览器中完美运行.

Thanks to @Stachu, the URL does not work manually on Internet Explorer on any PC (copy/pasting in the explorer navigation bar, I mean). The URL works perfectly in Google Chrome in all PC.

真的很好奇，手动运行Internet Explorer上的URL不起作用，但是用VBA编码并在Excel2007/2010上执行的相同URL可以很好地工作.也许我应该对编码进行一些更改?

It's really curious that, manually, the URL on Internet Explorer does not work, but same URL coded with VBA and Executed on Excel2007/2010 works perfectly. Maybe I should change something about the encoding?

更新6:仍在研究您的所有帖子.这里的问题是，我只是数据人员，分析师，所以这里发布的大量信息对我来说真的很重要.

UPDATE 6: Still studying all posts by you. The issue here is that I'm just the data guy, the analyst, so plenty of information posted here sounds really hardcore to me.

1天前，我已将所有信息通过电子邮件发送给IT人员，但仍在等待答案.

I've emailed all the info to the IT guys 1 day ago, and still waiting for an answer.

同时，根据此处的信息，最终对完全适用于所有计算机的代码进行了编码.它适用于Windows 7和10，适用于Excel 2007和2010(安装为32位)和Excel 2019(安装为64位).

Meanwhile, and based on information here, finally coded something totally different that works on all machines. It works on Windows 7 and 10, and it works on Excel 2007 and 2010 (installed as 32 bits) and Excel 2019 (installed as 64 bits).

我在这里添加代码，所以也许有人可以解释为什么它可以正常工作，但是看起来问题出在base64编码上.

I'm adding the code here, so maybe somebody can explain why it works properly, but it looks like the issue was the base64 encoding.

我现在得到的代码是这样的(添加了对Microsoft Winhttp Setvices 5.1的引用)

The code I got now is like this (added reference to Microsoft Winhttp Setvices 5.1)

Application.ScreenUpdating = False

Dim whr As WinHttp.WinHttpRequest
Dim oStream As Object
Dim EsteCSV As String
Dim EstaURL As String


EstaURL = "https://user:[e-mail]/export/target%20file.csv" 
EsteCSV = "CSV Datos" & Format(Date, "dd-mm-yyyy") & ".csv"

'Set whr = CreateObject("WinHttp.WinHttpRequest.5.1")

Set whr = New WinHttp.WinHttpRequest

whr.Open "GET", EstaURL, True
whr.setRequestHeader "Authorization", "Basic " & EncodeBase64("user" & ":" & "password")
whr.send

' Using 'true' above and the call below allows the script to remain responsive.
whr.waitForResponse
DoEvents

Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write whr.responseBody
oStream.SaveToFile ThisWorkbook.Path & "\" & EsteCSV
oStream.Close
DoEvents

Set oStream = Nothing
whr.abort
Set whr = Nothing
'rest of code for operations

Kill ThisWorkbook.Path & "\" & EsteCSV

Application.ScreenUpdating = True

End Sub

Private Function EncodeBase64(text As String) As String
  Dim arrData() As Byte
  arrData = StrConv(text, vbFromUnicode)

  Dim objXML As Object
  Dim objNode As Object

  Set objXML = CreateObject("MSXML2.DOMDocument")
  Set objNode = objXML.createElement("b64")

  objNode.DataType = "bin.base64"
  objNode.nodeTypedValue = arrData
  EncodeBase64 = objNode.text

  Set objNode = Nothing
  Set objXML = Nothing
End Function

推荐答案

感谢大家的帮助和解答.不幸的是，即使这里提供的所有链接都包含很多有用的信息，我的IT部门也无法告诉我确切的情况.

Thanks everybody for all your help and answers. Unfortunately, my IT department was not able to tell me what was happening exactly, even with all the links provided here with a lot of useful info.

我现在在这里发布我们在这里使用的代码.它可以在Excel 2007 32位，Excel 2010 32位和64位以及Excel 2019 64位上完美运行.在Windows 7和10上也可以使用.

I'm posting here the code we are using here right now. IT's works perfectly on Excel 2007 32 bit, Excel 2010 32 and 64 bits and Excel 2019 64 bits. It works too on Windows 7 and 10.

要使此代码正常工作，您需要添加对Microsoft Winhttp Setvices 5.1的引用.在如何在VBA中添加对象库引用如果您不知道该怎么做:

To make this code work, you need to add a reference to Microsoft Winhttp Setvices 5.1. Check How to Add an Object Library Reference in VBA in case you don't know how to do this:

Application.ScreenUpdating = False

Dim whr As WinHttp.WinHttpRequest
Dim oStream As Object
Dim EsteCSV As String
Dim EstaURL As String


EstaURL = "https://user:[e-mail]/export/target%20file.csv" 
EsteCSV = "CSV Datos" & Format(Date, "dd-mm-yyyy") & ".csv"

'Set whr = CreateObject("WinHttp.WinHttpRequest.5.1")

Set whr = New WinHttp.WinHttpRequest

whr.Open "GET", EstaURL, True
whr.setRequestHeader "Authorization", "Basic " & EncodeBase64("user" & ":" & "password")
whr.send

' Using 'true' above and the call below allows the script to remain responsive.
whr.waitForResponse
DoEvents

Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write whr.responseBody
oStream.SaveToFile ThisWorkbook.Path & "\" & EsteCSV
oStream.Close
DoEvents

Set oStream = Nothing
whr.abort
Set whr = Nothing
'rest of code for operations

Kill ThisWorkbook.Path & "\" & EsteCSV

Application.ScreenUpdating = True

End Sub

Private Function EncodeBase64(text As String) As String
  Dim arrData() As Byte
  arrData = StrConv(text, vbFromUnicode)

  Dim objXML As Object
  Dim objNode As Object

  Set objXML = CreateObject("MSXML2.DOMDocument")
  Set objNode = objXML.createElement("b64")

  objNode.DataType = "bin.base64"
  objNode.nodeTypedValue = arrData
  EncodeBase64 = objNode.text

  Set objNode = Nothing
  Set objXML = Nothing
End Function

再次感谢大家.所以是个好地方.

Thanks again everyone. SO is a great place.

这篇关于从Excel 2019中的URL下载文件(在Excel 2007上有效)的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！