VBA to Download documents using URLs, create a folder and save it in

[avlly]

Hi,

I found a VBA code on the forum that works perfectly, it downloads the URL images from the column A and saves it by the name specified in column B.

But instead of saving it by the name in column B, I would need to create a folder named from the values in column B and save the files there.

In column B I have duplicated values, so that means the cells with the same value are saved in the same folder. Names of the files can be same as the URLs.

Could anyone please please help me, it will save me a lot of time:)

Thanks,

Avlly

[Kenneth Hobs]

Welcome to the forum!


'Written: October 26, 2016'Author: Leith Ross
'Summary: Function Downloads A Web Site Resource To A Local Disk File


Private Const E_OUTOFMEMORY As Long = &H8007000E
Private Const INET_E_DOWNLOAD_FAILURE As Long = &H800C0008


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


Function DownloadURLtoFile(ByVal URL As String, ByVal vFolder As Variant, ByVal FileName As String) As Boolean
Dim Msg As String
Dim oFolder As Object

With CreateObject("Shell.Application")
Set oFolder = .Namespace(vFolder)
End With

If oFolder Is Nothing Then
MsgBox "Folder '" & vFolder & "' Not Found.", vbExclamation
Exit Function
End If

Select Case URLDownloadToFile(0&, URL, vFolder & FileName, 0&, 0&)
Case 0: DownloadURLtoFile = True
Case E_OUTOFMEMORY: Msg = "Insufficient Memory To Complete The Operation."
Case INET_E_DOWNLOAD_FAILURE: Msg = "The Specified Resource Or Callback Interface Was Invalid."
End Select

If Not DownloadURLtoFile Then Debug.Print Msg
End Function


Sub DownloadAndSave()
Dim Cell As Range, Cell2 As Range, Folder As String, Folder2 As String
Dim FSO, fn As String

Set FSO = CreateObject("Scripting.FileSystemObject")

Folder = CreateObject("Wscript.Shell").Specialfolders("Desktop") & "\"

On Error Resume Next
For Each Cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
Set Cell2 = Cell.Offset(, 1)
Folder2 = Folder & Cell2.Value2 & "\"
MkDir Folder2
fn = FSO.GetFilename(Cell.Value2)
If Dir(fn) = "" Then _
DownloadURLtoFile Cell.Value2, Folder2, fn
Next Cell

MsgBox "Done...", 64
Set FSO = Nothing
End Sub

[avlly]

Hi Kenneth,

Thank you SOOOO much!!!

But I have one issue, it doesn't allow me to save it anywhere else other than Desktop. I've changed the path, but no success it says Folder does not exist.

[avlly]

I got it now, the path wasn't correct. It works brilliantly, thank you again.