If you’d need to download several files based on some concatenated url’s it can be useful to build the url’s with Excel.
This little macro can then be used to download all the url’s found on the active sheet and store the files in a folder.
The target folder where the files need to be stored will be requested upon running the macro.
Based on some example VBA found online.
Sub DownloadUrlsOnSheet()
Dim iRow, iColumn As Long
Dim FileNum As Long
Dim FileData() As Byte
Dim MyFile As String
Dim WHTTP As Object
On Error Resume Next
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5")
If Err.Number <> 0 Then
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
End If
On Error GoTo 0
targetDir = BrowseForFolder
If (targetDir = False) Then
Exit Sub
End If
If Dir(targetDir, vbDirectory) = Empty Then MkDir targetDir
Set rngRange = Nothing
Set rngRange = Worksheets(ActiveCell.Worksheet.Name).Cells.Find("*", Worksheets(ActiveCell.Worksheet.Name).Cells(1, 1), xlFormulas, xlWhole, xlByRows, xlPrevious)
If Not rngRange Is Nothing Then
'if found then assign last non-empty cell row and colum index to the variable
lngMaxColumIndex = rngRange.Column
lngMaxRowIndex = rngRange.Row
Else
MsgBox ("Error clearing data, please check logs")
Exit Sub
End If
For iRow = 1 To lngMaxRowIndex
For iColumn = 1 To lngMaxColumIndex
currValue = Trim(Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Text)
If CheckURL(currValue) Then
TempFile = Right(currValue, InStr(1, StrReverse(currValue), "/") - 1)
WHTTP.Open "GET", currValue, False
WHTTP.Send
FileData = WHTTP.ResponseBody
FileNum = FreeFile
Open targetDir & "\" & TempFile For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
FileNum = FreeFile
Open targetDir & "\LogFile.txt" For Append As #FileNum
Print #FileNum, currValue & " --- Dowmloaded ----"
Close #FileNum
Else
FileNum = FreeFile
Open targetDir & "\LogFile.txt" For Append As #FileNum
Print #FileNum, currValue & " !!! File Not Found !!!"
Close #FileNum
End If
Next
Next
Set WHTTP = Nothing
MsgBox "Open the folder " & targetDir & " for the downloaded files..."
Shell "C:\WINDOWS\explorer.exe """ & targetDir & "", vbNormalFocus
End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
'
Function CheckURL(URL) As Boolean
Dim W As Object
On Error Resume Next
Set W = CreateObject("winhttp.winhttprequest.5")
If Err.Number <> 0 Then
Set W = CreateObject("winhttp.winhttprequest.5.1")
End If
On Error GoTo 0
If (Len(URL) < 4 Or Left(URL, 4) <> "http") Then
CheckURL = False
Exit Function
End If
On Error Resume Next
W.Open "HEAD", URL, False
W.Send
If W.Status = 200 Then
CheckURL = True
Else
CheckURL = False
End If
End Function
Posts
No comments:
Post a Comment