Download file with excel vba

Sometimes our Excel VBA applications need to interact with websites. Downloading a file through a URL is a typical example. In this lesson you can learn how to do that using XMLHttpRequest and ADODB.Stream object. XMLHttp is used to request the data from the web server. Once we receive the data from the server, the ADODB.Stream object is used to write that data to a file. You can use this method to download file types such as image files, csv files etc.

So let’s start writing our macro to download a file using the Uniform Resource Locator (URL). Let’s name our Sub procedure as “DownloadFileFromURL”

First we need to declare a few variables.

Dim FileUrl As String
Dim objXmlHttpReq As Object
Dim objStream As Object

Next assign the URL of the file to the FileUrl variables

FileUrl = «URL of your file»

For an example if your file URL is https://www.excelvbasolutions.com/images/chart.jpg then you can assign it to the variable as follows.

FileUrl = «https://www.excelvbasolutions.com/images/chart.jpg»

Next step is to create a XMLHttp object to request the data from the server.

Set objXmlHttpReq = CreateObject(«Microsoft.XMLHTTP»)

Call the open method followed by the send method.

objXmlHttpReq.Open «GET», FileUrl, False, «username», «password»
objXmlHttpReq.send

Then check the status. If it equals 200 (OK), we can move to the next step.

If objXmlHttpReq.Status = 200 Then

Now we need to create an ADODB.Stream object to write the data(received) to a file.

Set objStream = CreateObject(«ADODB.Stream»)

Stream in programming means flow of data. In programming data is what flows between processors and input or output devices. Check this link to see all the Properties, Methods and Events of Stream object.

Stream Object Properties, Methods, and Events

But we need to use only a few of them here.

objStream.Open
objStream.Type = 1
objStream.Write objXmlHttpReq.responseBody
objStream.SaveToFile ThisWorkbook.Path & «» & «file.jpg», 2
objStream.Close

In the SaveToFile method I have entered 2 as SaveOptions. So the program will overwrite the file with the data from the stream if the file already exists. If you don’t want to overwrite the existing file then replace it with 1.

objStream.SaveToFile ThisWorkbook.Path & «» & «file.jpg», 1

Below is the full code which you can use to download a file through a URL.

In the above example I showed how to download a .jpg file. But you can use this method to download other file types as well. Remember to change the file extension depending on the type of the file you download. For example if you are downloading a CSV file then the SaveToFile method should be changed as follows.

objStream.SaveToFile ThisWorkbook.Path & «» & «file.jpg», 2

Ok! 
This is getting considerably more difficult than I thought it would be when I made my first post. 
Nevertheless, I think you can get a working solution here. 
I’m sure the files are behind a firewall; I have no access to this domain. 
So, I’ll just offer some general truisms. 

For one thing, you MUST step through the code using the F8 key. 
Good tutorials here:

http://www.wiseowl.co.uk/blog/s196/step-through-code.htm

http://www.cpearson.com/excel/debug.htm

http://www.excel-vba.com/vba-prog-1-6-testing-macros.htm

You can get input for the username and password a few different ways:

http://www.ozgrid.com/VBA/inputbox-function.htm

I don’t think that’s the problem…just throwing it out there. 
That method is certainly better than a hard-coded solution.

Something like this should get you pretty close . . .

. . . OBVIOUSLY YOU NEED TO HIGHLY CUSTOMIZE IT FOR YOUR SPECIFIC SITUATION

Sub GoToWebSiteAndPlayAround()

‘These examples use late binding with the following two object libraries:

‘Microsoft Internet Controls (shdocvw.dll)

‘Microsoft HTML Object Library (MSHTML.TLB).

Dim oHTML_Element As IHTMLElement

Dim sURL As String

sURL = «https://www.google.com/accounts/Login»

Set oBrowser = New InternetExplorer

oBrowser.Silent = True

oBrowser.Navigate sURL

oBrowser.Visible = True

Do

‘ Wait till the Browser is loaded

Loop Until oBrowser.ReadyState = READYSTATE_COMPLETE

Set HTMLDoc = oBrowser.Document

HTMLDoc.all.Email.Value = «sample@vbadud.com»

HTMLDoc.all.passwd.Value = «*****»

‘NOTICE!!

‘You are now logged in to the site; run the next segment of code…

‘…do the file download…

Dim myURL As String

‘Right-click on the link named ‘Sample Address File’

‘Click ‘Copy Link Location’

‘Paste the link below

myURL = «http://databases.about.com/library/samples/address.xls»

Dim WinHttpReq As Object

Set WinHttpReq = CreateObject(«Microsoft.XMLHTTP»)

WinHttpReq.Open «GET», myURL, False

WinHttpReq.send

myURL = WinHttpReq.responseBody

   
Set oStream = CreateObject(«ADODB.Stream»)

   
oStream.Open

   
oStream.Type = 1

   
oStream.Write WinHttpReq.responseBody

   
oStream.SaveToFile («C:UsersExcelDesktopaddress.xls»)

   
oStream.Close

End Sub

REMEMBER, pop the code in, with your own modification, and hit F8 until it throws and error, or until . . . fingers crossed . . . it does what you want it
to do.

Try that and post back with the error, if you get one . . .

Good luck!!

Ryan Shuell

Excel VBA To Download File from Website  URL

In this article you will get VBA code to download file from any website URL.

Consider your have a list of files to download from internet from different website URLs. This might be a Video, Music, any Media or document like Doc, Pdf, Xlss, Csv, etc.

Also if any file is updated periodically, then you have to download them at certain time interval for data analysis. In this case, we can go for manual option, assigning a computer operator to download these files periodically.

Otherwise, you can choose to go for automating the whole process.

Lets see how to progress with this automation by comparing manual steps involved in it.

1. Manual Download:
   • We have to collect and log the URL link for each file in some document.
   • Browse each website and
   • Click on download file option provided in each of these websites.
2. Automatic Download: Let’s make it simple with Excel.
   • Type the file list to be downloaded from internet and all URLs corresponding to those files into an Excel sheet.
   • Use the VBA Macro code suggested in this article to download file from internet.

Note: This option is to download file from a HTTP internet server. If you have to download from your LAN local share path, you can use the option to copy files from this article.

If the File has to downloaded from a FTP server and not a HTTP URL path, read the below suggested article.

Also Read: Download or upload files from FTP server

Using VBA to Download File From URL Web Server from Excel?

The code snippet explained in this article will work out, if you have the exact file path and URL from the internet server.

Make sure that the URL you are providing is not a HTML page instead it should end with the File name that you are going to download.

Also Read: To download HTML data of Webpage, refer this article.

We are going to use the Windows API command ‘URLDownloadToFile’ for this purpose.

'Declaration of Windows API Function
#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
    Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
      Alias "DeleteUrlCacheEntryA" ( _
        ByVal lpszUrlName As String _
      ) 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
    Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
      Alias "DeleteUrlCacheEntryA" ( _
        ByVal lpszUrlName As String _
      ) As Long
#End If


Sub File_Download_From_Website()
    'Declare Local Variables to be Used in this Sub Module.
    Dim InpUrl As String
    Dim OutFilePath As String
    Dim DownloadStatus As Long
    
    'Read Input Path for the File and Output File Destination Path
    InpUrl = ThisWorkbook.Sheets(1).Cells(1, 1)
    OutFilePath = ThisWorkbook.Sheets(1).Cells(2, 1)
    
    'Invoke API to download file from the website.
    DownloadStatus = URLDownloadToFile(0, InpUrl, OutFilePath, 0, 0)
    
    'Check return status from the API and Intimate the User accordingly.
    If DownloadStatus = 0 Then
        Application.Speech.Speak "File Downloaded. Check in this path: " & OutFilePath, True
        MsgBox "File Downloaded. Check in this path: " & OutFilePath
    Else
        Application.Speech.Speak "Download File Process Failed"
        MsgBox "Download File Process Failed"
    End If
End Sub

This API will get the URL to download the file from and the destination where the file has to be downloaded.

API Syntax for File Download:

The get a detailed explanation of this API function, please refer the MSDN Library. We have provided a quick reference on the Parameters used by this Function URLDownloadToFile.

HRESULT URLDownloadToFile(
  LPUNKNOWN pCaller,
  LPCTSTR szURL,
  LPCTSTR szFileName,
  _Reserved_  DWORD dwReserved,
  LPBINDSTATUSCALLBACK lpfnCB
);

This kind of code may be used in analysis like a Compan’s Annual Earning Report, Stock Quotes etc., which gets refreshed periodically. This code snippet will save a lot of time in download these files from website URL manually.

More Tips: Download Social Media Profile Data To your PC

Часто требуется макросом скачать некий файл из интернета.
Обычно в этом помогает WinAPI-функция URLDownloadToFile, но есть также возможность загрузить файл без её использования:

Чем чревато использование функции URLDownloadToFile — по сути, ничем, кроме как необходимостью прописывать её в 2 вариантах, для обеспечения совместимости с 64-битной Windows

#If VBA7 Then        '  Office 2010-2013
    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 LongPtr
#Else        '  Office 2003-2007
    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
 
Function DownLoadFileFromURL(ByVal URL$, ByVal LocalPath$, Optional ByVal DisableCache As Boolean = False) As Boolean
    On Error Resume Next
    If (LocalPath$ = "") Or (URL$ = "") Then Exit Function
    If Not LocalPath$ Like "**" Then LocalPath$ = Environ("TEMP") & "" & LocalPath$
    Kill LocalPath$
    If DisableCache Then Randomize: URL$ = URL$ & "?rnd=" & Left(Rnd(Now) * 1E+15, 10)
    DownLoadFileFromURL = URLDownloadToFile(0, URL$, LocalPath$, 0, 0) = 0
End Function

Я же предлагаю другое решение — функцию DownloadFile с использованием объектов Microsoft.XMLHTTP и ADODB.Stream:

Sub ПримерИспользования()
    СсылкаНаФайл$ = "http://excelvba.ru/sites/default/files/3.jpg"
    ПутьДляСохранения$ = "C:1.jpg"
 
    ' скачиваем файл из интернета
    DownloadFile СсылкаНаФайл$, ПутьДляСохранения$
 
    ' открываем скачанный файл
    CreateObject("wscript.shell").Run """" & ПутьДляСохранения$ & """"
End Sub

Function DownloadFile(ByVal URL$, ByVal LocalPath$) As Boolean
    ' Функция скачивает файл по ссылке URL$
    ' и сохраняет его под именем LocalPath$
    Dim XMLHTTP, ADOStream, FileName
    On Error Resume Next: Kill LocalPath$
 
    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    XMLHTTP.Open "GET", Replace(URL$, "", "/"), "False"
    XMLHTTP.send
    If XMLHTTP.statustext = "OK" Then
        Set ADOStream = CreateObject("ADODB.Stream")
        ADOStream.Type = 1: ADOStream.Open
        ADOStream.Write XMLHTTP.responseBody
 
        ADOStream.SaveToFile LocalPath$, 2
        ADOStream.Close: Set ADOStream = Nothing
        DownloadFile = True
    Else
        'MsgBox "Не удаётся скачать файл " & XMLHTTP.statustext
    End If
    Set XMLHTTP = Nothing
End Function

There is no built-in function in Microsoft Excel which allows you to download contents from the Internet on the fly. To accomplish this task we need to use the API for WinInet. The use and explanation of API in VBA is for advanced users which have prior experience from either Visual Basic 6.0 or .NET.

Pitfalls

It is very important that all open Internet connections are closed as soon as the task is completed. WinInet only allows 2 concurrent connections to a given host. If you forget to shut down the connection after use, you will experience timeouts and misleading error messages. Please refer to the following website for more information related to the maximum allowed concurrent web connections:

• Adjust maximum concurrent connections

Howto

The source code below should be pasted in a “Class Module” in Excel. If you are not sure how to open the VBA editor in Excel for your current Microsoft Office version, please refer to the following page:

• Display the developer toolbar or ribbon in Excel

Create new class module:

1. Open the Microsoft Visual Basic for Applications editor in Excel.
2. Select Insert > Class Module on the main menubar
3. Rename the new class module to “WebClient“

Example

To use the code, you shold create a new instance of the class and any of the public methods:

• DownloadFile – download a specific resource to a local file
• UrlExists – check if a given URL exists

Dim objClient As New WebClient
Call objClient.DownloadFile("http://www.google.com", "c:test.html")

Dependencies

The function “ReThrowError” is defined here:

• Re-throw Errors in VBA

Source Code

' API
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Boolean

Private Enum EHttpQueryInfoLevel
    http_QUERY_CONTENT_TYPE = 1
    http_QUERY_CONTENT_LENGTH = 5
    http_QUERY_EXPIRES = 10
    http_QUERY_LAST_MODIFIED = 11
    http_QUERY_PRAGMA = 17
    http_QUERY_VERSION = 18
    http_QUERY_STATUS_CODE = 19
    http_QUERY_STATUS_TEXT = 20
    http_QUERY_RAW_HEADERS = 21
    http_QUERY_RAW_HEADERS_CRLF = 22
    http_QUERY_FORWARDED = 30
    http_QUERY_SERVER = 37
    http_QUERY_USER_AGENT = 39
    http_QUERY_SET_COOKIE = 43
    http_QUERY_REQUEST_METHOD = 45
    http_STATUS_DENIED = 401
    http_STATUS_PROXY_AUTH_REQ = 407
End Enum

Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hhttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" (ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" (ByVal hhttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, sOptional As Any, ByVal lOptionalLength As Long) As Integer

' Constants
Private Const INTERNET_FLAG_NO_CACHE_WRITE As Long = &H4000000
Private Const INTERNET_FLAG_NO_UI As Long = &H200
Private Const INTERNET_FLAG_EXISTING_CONNECT As Long = &H20000000
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3


' User Agent
Private Const USER_AGENT = "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)"



' Open
Private Function OpenSession()
    Dim hSession As Long

    ' Open internet connection
    hSession = InternetOpen(USER_AGENT, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)

    ' Valid session?
    If (hSession = 0) Then
        ' Error
        Err.Raise 1234, , "Unable to open internet connection!"
        
        ' Finished
        Exit Function
    End If
    
    ' Get the value
    OpenSession = hSession
End Function

' Close Handle
Private Sub CloseHandle(ByRef hHandle As Long)
   ' Valid handle?
   If (hHandle <> 0) Then
        ' Close
        Call InternetCloseHandle(hHandle)
        
        ' Clear handle
        hHandle = 0
    End If
End Sub


' Open Url
Private Function OpenUrl(ByVal hSession As Long, ByVal strUrl As String, Optional ByVal bRaiseError = True) As Long
    Dim hConnection As Long
    
    ' Valid session?
    If (hSession = 0) Then
        Err.Raise 2345345, , "The session is not set!"
        Exit Function
    End If
    
    ' Open Url
    hConnection = InternetOpenUrl(hSession, strUrl, vbNullString, ByVal 0&, INTERNET_FLAG_EXISTING_CONNECT Or INTERNET_FLAG_RELOAD, ByVal 0&)

     ' Valid file?
    If (hConnection = 0) Then
        ' Error
        Call RaiseLastError
        
        ' Exit
        Exit Function
    End If

    ' Get the value
    OpenUrl = hConnection

End Function

' Raise Last Error
Private Sub RaiseLastError()
    Dim strErrorMessage As String
    Dim lngErrorNumber As Long

    ' Get the last error
    lngErrorNumber = Err.LastDllError
    
    ' Valid error?
    If (lngErrorNumber <> 0) Then
        ' Error
        Err.Raise lngErrorNumber, , "DLL Error: " & CStr(lngErrorNumber)
    Else
        ' Get the error
        If (GetLastResponseInfo(lngErrorNumber, strErrorMessage)) Then
            ' Raise error
            Err.Raise lngErrorNumber, , strErrorMessage
        End If
    End If
End Sub

' Get Last Response Info
Private Function GetLastResponseInfo(ByRef lngErrorNumber As Long, ByRef strErrorMessage As String) As Boolean
    Dim intResult As Integer
    Dim lngBufferLength As Long
    
    ' Get the required buffer size
    intResult = InternetGetLastResponseInfo(lngErrorNumber, strErrorMessage, lngBufferLength)
        
    ' Valid length?
    If (lngErrorNumber <> 0) Then
        ' Allcoate the buffer
        strErrorMessage = String(lngBufferLength, 0)
        
        ' Retrieve the last respons info
        intResult = InternetGetLastResponseInfo(lngErrorNumber, strErrorMessage, lngBufferLength)
    
        ' Get the error message
        GetLastResponseInfo = True
        Exit Function
    End If
    
    ' Not an error
    GetLastResponseInfo = False
End Function


' File Exists?
Public Function UrlExists(ByVal strUrl As String) As Boolean
    On Error GoTo ErrorHandler
    
    Const BUFFER_LENGTH As Long = 255
    
    Dim hSession As Long
    Dim hConnection As Long
    Dim strBuffer As String * BUFFER_LENGTH
    Dim intBufferLength As Long
    Dim intResult As Integer
    Dim lngIndex As Long
    Dim strStatusCode As String
    Dim intStatusCode As Integer
    
    ' Open Session
    hSession = OpenSession
    
    ' Open the file
    hConnection = OpenUrl(hSession, strUrl, False)
    
    ' Set the default bufferlength
    intBufferLength = BUFFER_LENGTH
    
    ' Get the status code
    intResult = HttpQueryInfo(hConnection, http_QUERY_STATUS_CODE, ByVal strBuffer, intBufferLength, lngIndex)
    
    ' Valid value?
    If (intResult <> 0) Then
        ' Get the status code string
        strStatusCode = Left(strBuffer, intBufferLength)
        
        ' Get the integer status code
        intStatusCode = CInt(strStatusCode)
        
        ' Check the status code
        UrlExists = (intStatusCode = 200)
    End If
    
    ' Close the connection
    Call CloseHandle(hConnection)
    Call CloseHandle(hSession)
    Exit Function
    
ErrorHandler:
    Call CloseHandle(hConnection)
    Call CloseHandle(hSession)
    
    ' Re-throw
    Call ReThrowError(Err)
End Function


' Download File
Public Sub DownloadFile(ByVal strUrl As String, ByVal strFilename As String)
    On Error GoTo ErrorHandling
    
    ' Buffer size
    Const BUFFER_SIZE As Integer = 4096
    
    Dim hSession As Long
    Dim hConnection As Long
    Dim strBuffer As String * BUFFER_SIZE
    Dim intFile As Integer
    Dim lngRead As Long
    Dim intResult As Integer

    ' Open session
    hSession = OpenSession()

    ' Open the file
    hConnection = OpenUrl(hSession, strUrl)
    
    ' Find free file
    intFile = FreeFile
    
    ' Create file
    Open strFilename For Binary As #intFile
    
        Do
            ' Read the data
            intResult = InternetReadFile(hConnection, strBuffer, BUFFER_SIZE, lngRead)
    
            ' Valid function?
            If (intResult <> 0) Then
            
                ' Valid number of bytes read?
                If (lngRead > 0) Then
                
                    ' Is less than buffer size?
                    If (lngRead < BUFFER_SIZE) Then
                    
                        ' Get only the relevant data
                        strBuffer = Left(strBuffer, lngRead)
                    End If
                
                    ' Write the data
                    Put #intFile, , strBuffer
                End If
            End If
            
        Loop While (lngRead > 0)
        
    ' Close the file
    Close #intFile
    
ExitMe:
    ' Close connection
    Call CloseHandle(hConnection)
    Call CloseHandle(hSession)
    Exit Sub
    
ErrorHandling:
    ' Close connection
    Call CloseHandle(hConnection)
    Call CloseHandle(hSession)
     
    ' Rethrow
    Call ReThrowError(Err)

End Sub

Related

• Send e-mails using Excel VBA
• Get Microsoft Excel

Хитрости »

2 Декабрь 2016              40443 просмотров

Как скачать файл из интернета по ссылке

Вся суть статьи уже в заголовке. Возникает порой необходимость скачивания файлов из интернета только на основании ссылки. Например, это какие-то постоянно меняющиеся данные или автоматически генерируемая другим кодом ссылка. Или еще более усугубленный вариант — строк 100 со ссылками на файлы, которые надо скачать…Вот уж радости руками по каждой клацать
Поэтому выкладываю решение, которое в большинстве случае поможет при помощи Visual Basic for Applications скачать файл на основании ссылки URL:

'---------------------------------------------------------------------------------------
' File   : mDownloadFileFromURL
' Purpose: код позволяет скачивать файлы из интернета по указанной ссылке
'---------------------------------------------------------------------------------------
Option Explicit
 
'объявление функции API - URLDownloadToFile
'   работает на любых ПК под управлением ОС Windows
'   на MAC код работать не будет
#If Win64 Then 'для операционных систем с 64-разрядной архитектурой
    Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
            (ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _
             ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong
#Else
    #If VBA7 Then 'для любых операционных систем с офисом 2010 и выше
        Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
            (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
                ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As LongPtr
    #Else 'для 32-разрядных операционных систем
        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
#End If
'переменная для хранения пути к папке
Dim sFilePath As String
 
Function CallDownload(sFileURL As String, sFileName As String)
'   sFileURL  - ссылка URL для скачивания файла
'   sFileName - имя файла с расширением, которое будет присвоено после скачивания
 
    Dim h
    If sFilePath = "" Then
        'диалоговое окно выбора папки
        'подробнее: http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = False Then
                Exit Function
            End If
            sFilePath = .SelectedItems(1)
        End With
    End If
 
    If Right(sFilePath, 1) <> "" Then sFilePath = sFilePath & ""
    'проверяем есть ли файл с таким же именем в выбранной папке
    If Dir(sFilePath & sFileName, 16) = "" Then
        'файла нет - скачиваем
        h = DownloadFileAPI(sFileURL, sFilePath & sFileName)
    Else
        'файл есть - запрос на перезапись
        If MsgBox("Этот файл уже существует в папке: " & sFilePath & vbNewLine & "Перезаписать?", vbYesNo, "www.excel-vba.ru") = vbYes Then
            'если существующий файл открыт - невозможно его перезаписать, показываем инф.окно
            'отменяем загрузку
            If IsBookOpen(sFileName) Then
                MsgBox "Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл '" & sFileName & "' и этот файл открыт." & _
                    vbNewLine & "Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru"
            Else
                h = DownloadFileAPI(sFileURL, sFilePath & sFileName)
            End If
        End If
    End If
    CallDownload = h
End Function
 
'функция скачивания файла в выбранную папку
Function DownloadFileAPI(sFileURL, ToPathName)
'   sFileURL   - ссылка URL для скачивания файла
'   ToPathName - полный путь с именем файла для сохранения
 
    Dim h
    Dim sFilePath As String
    Dim sFileName As String
    'вызов функции API для непосредственно скачивания
    h = (URLDownloadToFile(0, sFileURL, ToPathName, 0, 0) = 0)
    'если h = False - файл не удалось скачать, показываем инф.окно
    If h = False Then
        MsgBox "Невозможно скачать файл." & vbNewLine & _
                "Возможно, у Вас нет прав на создание файлов в выбранной директории." & vbNewLine & _
                "Попробуйте выбрать другую папку для сохранения", vbInformation, "www.excel-vba.ru"
                Exit Function
    Else 'файл успешно скачан
            sFileName = Dir(ToPathName, 16)
            sFilePath = Replace(ToPathName, sFileName, "")
            If MsgBox("Файл сохранен в папку: " & sFilePath & _
                              vbNewLine & "Открыть файл сейчас?", vbYesNo, "www.excel-vba.ru") = vbYes Then
                If IsBookOpen(sFileName) Then
                    MsgBox "Файл с именем '" & sFileName & "' уже открыт. Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru"
                Else
                    Workbooks.Open ToPathName
                End If
            End If
    End If
    DownloadFileAPI = h
End Function
'Функция проверки - открыта ли книга с заданным именем
'подробнее:
'        http://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/
Function IsBookOpen(wbName As String) As Boolean
    Dim wbBook As Workbook
    For Each wbBook In Workbooks
        If Windows(wbBook.Name).Visible Then
            If wbBook.Name = wbName Then IsBookOpen = True: Exit For
        End If
    Next wbBook
End Function

Код необходимо скопировать и вставить в книгу в стандартный модуль. Макросы должны быть разрешены.

Основная функция, отвечающая за непосредственно скачивание — это функция API(Application Programming Interface) URLDownloadToFile. Она объявлена в самом верху кода. Там есть страшные директивы вроде #If Win64 Then. Это особые директивы, которые работают даже вне процедур. Поэтому не надо удивляться, что они вне всяких Sub и тем более не надо эти Sub-ы добавлять. При этом так же не надо удивляться, если какие-то из строк внутри этих директив будут подсвечены компилятором VBA красным шрифтом. На функциональность это не повлияет.

Вызов скачивания файла происходит обычным обращением к функции CallDownload. Например, есть ссылка для скачивания: http://www.excel-vba.ru/files/book.xls. И сохранить надо под именем «Книга1.xls». Вызываем функцию скачивания файла:

Sub DownloadFile()
    Call CallDownload("http://www.excel-vba.ru/files/book.xls", "Книга1.xls") 'вызываем скачивание файла
End Sub

Функция сама запросит папку для сохранения файла и после скачивания предложит открыть этот файл. Если такой файл уже есть — будет предложено его перезаписать.
К статье приложен файл, в котором код чуть расширен — он позволяет скачивать файлы сразу из множества ячеек, проставляя при этом признак — скачан файл или нет. И если сразу весь список обработать не получилось и какие-то файлы остались не скачанные(например, имена совпадали, а заменять файлы не надо было), то в этом случае можно будет повторно запустить код и скачиваться будут лишь те, у которых статус не является «Скачан!».
Так же т.к. ячеек много, перед скачиванием файлов будет выбор — запрашивать ли открытие файлов после скачивания или нет. Если открывать не надо, следует ответить Нет. Тогда файлы просто будут скачаны в указанную папку. Однако, если в этой папке будут расположены файлы с идентичными именами — запрос на перезапись все же появится, при этом для каждого файла. Если подобный запрос так же мешает, то надо этот блок:

    'проверяем есть ли файл с таким же именем в выбранной папке
    If Dir(sFilePath & sFileName, 16) = "" Then
        'файла нет - скачиваем
        h = DownloadFileAPI(sFileURL, sFilePath & sFileName)
    Else
        'файл есть - запрос на перезапись
        If MsgBox("Этот файл уже существует в папке: " & sFilePath & vbNewLine & "Перезаписать?", vbYesNo, "www.excel-vba.ru") = vbYes Then
            'если существующий файл открыт - невозможно его перезаписать, показываем инф.окно
            'отменяем загрузку
            If IsBookOpen(sFileName) Then
                MsgBox "Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл '" & sFileName & "' и этот файл открыт." & _
                    vbNewLine & "Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru"
            Else
                h = DownloadFileAPI(sFileURL, sFilePath & sFileName)
            End If
        End If
    End If

заменить на всего одну строку:

h = DownloadFileAPI(sFileURL, sFilePath & sFileName)

Но при этом надо помнить — что при этом можно потерять какие-то важные файлы. Поэтому подобные вещи вы делаете на свой страх и риск.

Однако следует помнить одну вещь: не все сайты вот так запросто разрешают скачивать с них файлы, тем более пачками. Особенно это актуально для всякого рода форексов и иже с ними. Возможно, получится скачать один, два, три — десять файлов. Но всегда может случиться так, что сайт просто заблокирует ваш IP до конца дня, т.к. на сайте установлено ограничение на автоматизированное обращение извне. При этом для разных сайтов решение данной проблемы может быть различным и не всегда решаемым

Скачать файл

  Tips_Macro_DownloadFileFromURL.xls (64,0 KiB, 3 837 скачиваний)

Статья помогла? Поделись ссылкой с друзьями!

    Видеоуроки

Поиск по меткам



Access
apple watch
Multex
Power Query и Power BI
VBA управление кодами
Бесплатные надстройки
Дата и время
Записки
ИП
Надстройки
Печать
Политика Конфиденциальности
Почта
Программы
Работа с приложениями
Разработка приложений
Росстат
Тренинги и вебинары
Финансовые
Форматирование
Функции Excel
акции MulTEx
ссылки
статистика