Загрузить файл с URL-адреса в Excel 2019 (работает в Excel 2007)

Question

Я получил код для загрузки файла CSV с веб-сайта, который требует учетные данные. Благодаря этому сайту я получил код и смог приспособиться к своим потребностям. Моя соответствующая часть кода:

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:token@www.privatewebsite.com/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

Извините, но я не могу предоставить реальный URL. В любом случае, этот код отлично работает с сентября 2019 года. И он по-прежнему отлично работает каждый день.

Все компьютеры, которые выполняют этот код, Windows 7 и Excel 2007 и 64-разрядные. Ни один из них не сработает.

Но теперь эта задача будет передана в другой офис. Там компьютеры Excel 2019, Windows 10 и 64 бита.

И код там не работает. Никаких ошибок не возникает, но функция DownloadUrlFile не загружает никаких файлов в Excel 2019 + W10

Итак, для возобновления Excel 2007 + Windows 7 работает отлично (проверено сегодня). Excel 2019 + Windows 10 не работает (без ошибок на экране).

Вещи, которые я пытался исправить:

1. Я проверил этот файл urlmon.dll существует в system32 и
2. Я пытался объявить функцию URLDownloadToFileA, используя PtrSafe
3. Если я вручную наберу URL в Chrome в P C в Excel 2019 + W10, файл загружен правильно, поэтому URL-адрес в порядке.

Ничто из этого не решило мою проблему. Я уверен, что решение действительно простое, потому что код отлично работает в Excel 2007, но я не могу найти то, что мне здесь не хватает.

Я хотел бы получить код, который работает в любом случай, но я бы также принял решение, которое работает только в Excel 2019 и Windows 10, если это единственный способ.

Надеюсь, кто-нибудь может пролить свет на это. Заранее спасибо.

ОБНОВЛЕНИЕ : Пробовал также решение в этом сообщении , но все еще ничего.

ОБНОВЛЕНИЕ 2: Кроме того, протестировал код, размещенный здесь (Excel 2007) в Excel 2010, и он отлично работает.

ОБНОВЛЕНИЕ 3: В переменной RetVal хранится результат загрузки. Я знаю некоторые значения:

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

Но в моем случае возвращается -2147221020. Что бы это могло быть?

ОБНОВЛЕНИЕ 4: Ну, это просто странно. Я попробовал тот же код, чтобы загрузить другой файл с веб-сайта publi c, и он работает в Excel 2019 + W10. Я сделал новый простой код, подобный этому:

#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, отлично работает и загружает файл.

Строка URLDownloadToFile 0, EstaURL, ThisWorkbook.Path & "\" & EsteCSV, 0, 0 не работает.

Итак, снова протестирован точно такой же код, но в Excel 2007 и оба они работают

Почему первая загрузка работает, а вторая - не в Excel 2019 + W10, но оба они работа в Excel 2007 + W7?

ОБНОВЛЕНИЕ 5: URL-адрес является закрытым, поскольку содержит имя пользователя и пароль, но выглядит так:

https://user:token@www.privatewebsite.com/export/target%20file.csv

Благодаря @Stachu, URL не работает вручную на Inte rnet Explorer на любом P C (я имею в виду копирование / вставка в панели навигации проводника). URL отлично работает в Google Chrome во всех P C.

. Любопытно, что вручную, URL в Inte rnet Explorer не работает, но тот же URL, закодированный с VBA и Executed on Excel2007 / 2010 работает отлично. Может мне стоит что-то изменить в кодировке?

ОБНОВЛЕНИЕ 6: Все еще изучаю все ваши сообщения. Проблема здесь в том, что я просто специалист по обработке данных, аналитик, поэтому большое количество информации, размещенной здесь, звучит для меня по-настоящему хардкорно.

Я отправил всю информацию по электронной почте парням ИТ 1 день в go и все еще жду ответа.

Между тем, основываясь на приведенной здесь информации, наконец-то закодировано нечто совершенно другое, которое работает на всех машинах. Он работает на Windows 7 и 10 и работает на Excel 2007 и 2010 (установлен как 32-разрядные) и Excel 2019 (установлен как 64-разрядные).

Я добавляю код здесь, так что, возможно, кто-то может объяснить, почему он работает должным образом, но похоже, что проблема заключалась в кодировке base64.

Код, который я получил сейчас, выглядит следующим образом (добавлена ​​ссылка на 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:pass@www.privatewebsite.com/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

Answer 1

Я попробовал это решение в Excel 2019 / O365 64 бит (версия: 1912) / win 10 64 бит

Я знаю, что у вас есть рабочий код, но если кому-то еще нужна альтернатива, вот он:

Sub DownloadFile()

    Dim evalURL As String
    Dim streamObject As Object
    Dim winHttpRequest As Object
    Set winHttpRequest = CreateObject("Microsoft.XMLHTTP")

    evalURL = "https://fullPathTofile/tst.csv" ' -> Didn't need to add the username at the beginning

    winHttpRequest.Open "GET", evalURL, False, "username", "password"
    winHttpRequest.send

    If winHttpRequest.Status = 200 Then
        Set streamObject = CreateObject("ADODB.Stream")
        streamObject.Open
        streamObject.Type = 1
        streamObject.Write winHttpRequest.responseBody
        streamObject.SaveToFile "C:\temp\file.csv", 2 ' 1 = no overwrite, 2 = overwrite
        streamObject.Close
    End If

End Sub

Answer 2

Все компьютеры, которые выполняют этот код, Windows 7 и Excel 2007 и 64-разрядные. Ни один из них не сработает.

Но теперь эта задача будет передана в другой офис. Там компьютеры Excel 2019, Windows 10 и 64 бита.

И код там не работает. Не возникает никаких ошибок, но функция DownloadUrlFile не загружает никаких файлов в Excel 2019 + W10

Я предполагаю, что она не работает в другом офисе.

Это произойдет, только если URL является частным, а IP-адреса не включены в белый список. Вы можете уточнить у своей сетевой команды, есть ли у них белый список IP-адресов для этого URL.

Строка, которая говорит URLDownloadToFile 0, "https://tutorialesexcel.com/wp-content/uploads/2018/10/funciones.xlsm" , ThisWorkbook.Path & "\" & EsteCSV, 0, отлично работает и загружает файл.

Строка URLDownloadToFile 0, EstaURL, ThisWorkbook.Path & "\" & EsteCSV, 0, 0 не работает.

Итак, снова протестирован точно такой же код, но в Excel 2007, и оба они работают

Почему первая загрузка работает, а вторая - в Excel 2019 + W10, но обе они работают в Excel 2007 + W7?

Кроме того, не имеет смысла, что один и тот же код прекрасно работает для публичного URL c, а не для частного URL, за исключением ограничения IP.

Answer 3

Что касается вашей ошибки, -2147221020 => 0x800401E4 согласно Коды ошибок VBA и описания эта ошибка - MK_E_SYNTAX, которая является 'недопустимым синтаксисом моникера'.

Когда это говорит, что я думаю, что прозвище это означает, что ваш URL-адрес и, честно говоря, веб-адрес не выглядит синтаксически правильным ...

"https://user:token@www.privatewebsite.com/export/targetfile.csv"

Мне нужно покопаться, чтобы убедиться, что он действительно соответствует веб-стандарту. для URL. А пока я бы предложил выяснить другой URL. Возможно, что обновление до urlmon.dll теперь жалуется на URL, тогда как версия Windows 7 этого не сделала.

Ладно, плохо, на самом деле, похоже, что вы можете сделать такой Uris, теоретически, так У меня есть фрагмент uri

first-client:noonewilleverguess@localhost:8080/oauth/token, взятый из OAuth2 Boot

Хорошо, так что он действителен, к началу страницы 17 rfc3986 .

authority = [ userinfo "@" ] host [ ":" port ]

Похоже, вам придется заходить в Windows вызовы API для установки имени пользователя и пароля. Итак, вот пример кода

Option Explicit

'* with thanks to http://www.holmessoft.co.uk/homepage/WininetVB.htm

Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
    ByVal lpszAgent As String, _
    ByVal dwAccessType As Long, _
    ByVal lpszProxyName As String, _
    ByVal lpszProxyBypass As String, _
    ByVal dwFlags As Long) As Long


Private Enum InternetOpenAccessTypes
    INTERNET_OPEN_TYPE_PRECONFIG = 0 'Retrieves the proxy or direct configuration from the registry.
    INTERNET_OPEN_TYPE_DIRECT = 1 'Resolves all host names locally.
    INTERNET_OPEN_TYPE_PROXY = 3 'Passes requests to the proxy unless a proxy bypass list is supplied and the name to be resolved bypasses the proxy. In this case, the function uses INTERNET_OPEN_TYPE_DIRECT.
    INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 'Retrieves the proxy or direct configuration from the registry and prevents the use of a startup Microsoft JScript or Internet Setup (INS) file.
End Enum


Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
    ByVal hInternetSession As Long, _
    ByVal lpszServerName As String, _
    ByVal nServerPort As Integer, _
    ByVal lpszUsername As String, _
    ByVal lpszPassword As String, _
    ByVal dwService As Long, _
    ByVal dwFlags As Long, _
    ByVal dwContext As Long) As Long

Private Const INTERNET_SERVICE_HTTP = 3

Private Const INTERNET_FLAG_NO_COOKIES = &H80000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000

Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" ( _
    ByVal hHttpSession As Long, _
    ByVal lpszVerb As String, _
    ByVal lpszObjectName As String, _
    ByVal lpszVersion As String, _
    ByVal lpszReferer As String, _
    ByVal lpszAcceptTypes As String, _
    ByVal dwFlags As Long, _
    ByVal dwContext As Long) As Long

Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" ( _
    ByVal hHttpRequest As Long, _
    ByVal lpszHeaders As String, _
    ByVal dwHeadersLength As Long, _
    ByVal lpOptional As String, _
    ByVal dwOptionalLength As Long) As Boolean

Private Declare Function InternetReadFile Lib "wininet.dll" ( _
    ByVal hFile As Long, _
    ByVal lpBuffer As String, _
    ByVal dwNumberOfBytesToRead As Long, _
    ByRef lpNumberOfBytesRead As Long) As Boolean

Private Sub Test()
    Dim hInternet As Long
    hInternet = InternetOpen("Mozilla", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
    If hInternet = 0 Then
        Debug.Print "InternetOpen failed"
        GoTo SingleExit
    End If

    Dim sUSERNAME As String
    sUSERNAME = "foo"

    Dim sPASSWORD As String
    sPASSWORD = "bar"


    Dim hConnect As Long
    hConnect = InternetConnect(hInternet, "www.microsoft.com", 80, sUSERNAME, sPASSWORD, INTERNET_SERVICE_HTTP, 0, 0)
    If hConnect = 0 Then
        Debug.Print "InternetConnect failed"
        GoTo SingleExit
    End If

    Dim lFlags As Long
    Dim hRequest As Long

    lFlags = INTERNET_FLAG_NO_COOKIES
    lFlags = lFlags Or INTERNET_FLAG_NO_CACHE_WRITE

    hRequest = HttpOpenRequest(hConnect, "GET", "www.microsoft.com", "HTTP/1.0", vbNullString, vbNullString, lFlags, 0)

    Dim bRes As Boolean
    bRes = HttpSendRequest(hRequest, vbNullString, 0, vbNullString, 0)

    Dim strFile As String
    strFile = "downloadedfile.txt"

    Dim strBuffer As String * 1
    Dim strDir As String
    strDir = Dir(ThisWorkbook.Path & "\" & strFile)
    If Len(strDir) > 0 Then
        Kill ThisWorkbook.Path & "\" & strFile
    End If

    Dim iFile As Long
    iFile = FreeFile()
    Open ThisWorkbook.Path & "\" & strFile For Binary Access Write As iFile

    Do
        Dim lBytesRead As Long
        bRes = InternetReadFile(hRequest, strBuffer, Len(strBuffer), lBytesRead)
        If lBytesRead > 0 Then
            Put iFile, , strBuffer
        End If
    Loop While lBytesRead > 0

    Debug.Print "finished"
SingleExit:


End Sub

ОБНОВЛЕНИЕ: Поздравляем вас с решением, для которого вы предлагаете объяснение, возможно, смотрите этот Форум MSDN , где в дискурсе описываются различные технологические стеки. Если я просматриваю заголовочный файл C ++ urlmon.h, тогда URLDownloadToFile выглядит так, как будто он основан на WinInet. Поэтому переключение на WinHTTP - это разумный переход к стеку, основанному на большем количестве серверов.
Кроме того, в той же логике стека c, я полагаю, вы могли бы использовать MSXML2.ServerXMLHTTP. *

Answer 4

Подкод в порядке. Проверьте ссылки в меню инструментов в vba и сделайте объявление ptrsafe, как показано ниже

Private Declare PtrSafe Function URLDownloadToFileA Lib "urlmon" _

Answer 5

«Упрощенный» метод, который вы использовали (user+password@url), в лучшем случае имел пятнистую поддержку из-за потенциальной возможности удаленного злоупотребления. Некоторые браузеры больше даже не поддерживают его .

^{Например, для использования нескольких маршрутизаторов, защищенных только «запретить удаленный доступ», достаточно ссылки HREF ...admin:admin@192.168.1.1/cgi-bin/something-else?.... "по умолчанию вместо надежного пароля, и существует много из них.}

Вы могли бы преодолеть это, сохранив пользователя и пароль в Inte rnet Explorer, библиотеки которого используются Excel, и / или помещение удаленного сайта в группу «Надежные сайты» из Inte rnet Options. Но это также и временная мера, поскольку кэш пароля может быть удален случайно, а уровни безопасности могут быть сброшены обновлением в любое время (у меня это случалось не раз).

Здесь обсуждаются и другие методы. В противном случае ваше решение, конечно, будет работать (вы можете добавить ответ на этот вопрос и отметить его как принятое для следующего, кто столкнется с той же проблемой).

Answer 6

Спасибо всем за помощь и ответы. К сожалению, мой ИТ-отдел не смог мне точно сказать, что происходило, даже со всеми ссылками, приведенными здесь, с большим количеством полезной информации.

Я публикую здесь код, который мы сейчас здесь используем. ИТ отлично работает в 32-разрядной версии Excel 2007, 32-разрядной версии Excel 2010 и 64-разрядной версии Excel 2019. Он также работает на Windows 7 и 10.

Чтобы этот код работал, вам нужно добавить ссылку на Microsoft Winhttp Setvices 5.1. Проверьте Как добавить ссылку на библиотеку объектов в VBA , если вы не знаете, как это сделать:

Application.ScreenUpdating = False

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


EstaURL = "https://user:pass@www.privatewebsite.com/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

Еще раз спасибо всем. ТАК отличное место.