[HELP] Download images from a list of urls (in excel sheet) to my local disk

[anto888]

Hi, i have a sheet with a list of urls of some pictures:


http://www.mysite.com/cbcuu/$5Gbewh60.jpg
http://www.mysite.com/cbcuu/$"£%"£wh60.jpg
http://www.mysite.com/cbcuu/$rf34ewh60.jpg
http://www.mysite.com/cbcuu/$5G$£h60.jpg
http://www.mysite.com/cbcuu/$5G65h60.jpg
http://www.mysite.com/cbcuu/$5G"£££h60.jpg
http://www.mysite.com/cbcuu/$5Gbtgtgh60.jpg


I need a tool that will automatically connect to the url and download the images in a folder.
So now i have new urls like these:


C:\User\Anto\Pictures\$5Gbewh60.jpg
C:\User\Anto\Pictures\$"£%"£wh60.jpg
etc.


Then the tool must re-insert the new urls in the excel sheet near the old urls.


I hope this can be done in excel. Thanks very much and sorry for my not-perfect english.


Hope you have a nice day.

 

[Case_Germany]

Hi,

the following code from my blog...

VBA und VB DOT.NET: Internet - Picture - Download!

...slightly adapted:

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Private Declare Function DeleteUrlCacheEntry Lib "wininet" Alias _
    "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
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
Const strPath As String = "C:\PicDown\"
Public Sub Main()
    Dim wksSheet As Worksheet
    Dim lngLastRow As Long
    Dim strFile As String
    Dim lngResult As Long
    Dim strURL As String
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    MakeSureDirectoryPathExists strPath
    Kill strPath & "*.*"
    Set wksSheet = ThisWorkbook.Worksheets("Sheet1")
    With wksSheet
        lngLastRow = IIf(IsEmpty(.Range("B" & .Rows.Count)), _
            .Range("B" & .Rows.Count).End(xlUp).Row, .Rows.Count)
        .Range(.Cells(1, 3), .Cells(lngLastRow, 3)).Clear
        For lngLastRow = 1 To lngLastRow
            strURL = .Cells(lngLastRow, 2).Text
            strFile = strPath & lngLastRow & "_" & _
                Mid(strURL, InStrRev(strURL, "/") + 1)
            Call DeleteUrlCacheEntry(strURL)
            lngResult = URLDownloadToFile(0, strURL, strFile, 0, 0)
            If ExistFile(strFile) = True Then
                If FileLen(strFile) > 1000 Then
                    .Cells(lngLastRow, 3).Value = strFile
                    .Cells(lngLastRow, 3).Hyperlinks.Add _
                        Anchor:=.Cells(lngLastRow, 3), _
                        Address:=strFile
                Else
                    .Cells(lngLastRow, 3).Value = "???"
                End If
            Else
                .Cells(lngLastRow, 3).Value = "No file"
            End If
        Next
    End With
Fin:
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function ExistFile(Pfad As String) As Boolean
    On Error Resume Next
    ExistFile = Not CBool(GetAttr(Pfad) And (vbVolume))
    On Error GoTo 0
End Function

Here is a sample file.

 

[Case_Germany]

Hi,

the gremlin has struck...

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Private Declare Function DeleteUrlCacheEntry Lib "wininet" Alias _
    "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" _
    Alias "PathFileExistsA" (ByVal pszPath As String) As Long
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
Const strPath As String = "C:\PicDown\"
Public Sub Main()
    Dim wksSheet As Worksheet
    Dim lngLastRow As Long
    Dim strFile As String
    Dim lngResult As Long
    Dim strURL As String
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    MakeSureDirectoryPathExists strPath
    If IsFilePath(strPath) Then
        On Error Resume Next
        Kill strPath & "*.*"
        On Error GoTo Fin
    End If
    Set wksSheet = ThisWorkbook.Worksheets("Sheet1")
    With wksSheet
        lngLastRow = IIf(IsEmpty(.Range("B" & .Rows.Count)), _
            .Range("B" & .Rows.Count).End(xlUp).Row, .Rows.Count)
        .Range(.Cells(1, 3), .Cells(lngLastRow, 3)).Clear
        For lngLastRow = 1 To lngLastRow
            strURL = .Cells(lngLastRow, 2).Text
            strFile = strPath & lngLastRow & "_" & _
                Mid(strURL, InStrRev(strURL, "/") + 1)
            Call DeleteUrlCacheEntry(strURL)
            lngResult = URLDownloadToFile(0, strURL, strFile, 0, 0)
            If ExistFile(strFile) = True Then
                If FileLen(strFile) > 1000 Then
                    .Cells(lngLastRow, 3).Value = strFile
                    .Cells(lngLastRow, 3).Hyperlinks.Add _
                        Anchor:=.Cells(lngLastRow, 3), _
                        Address:=strFile
                Else
                    .Cells(lngLastRow, 3).Value = "???"
                End If
            Else
                .Cells(lngLastRow, 3).Value = "No file"
            End If
        Next
    End With
Fin:
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function IsFilePath(strPath As String) As Boolean
    IsFilePath = CBool(PathFileExists(strPath))
End Function
Private Function ExistFile(Pfad As String) As Boolean
    On Error Resume Next
    ExistFile = Not CBool(GetAttr(Pfad) And (vbVolume))
    On Error GoTo 0
End Function

 

[cecowe]

Hey Case, may I rename the files names in advance, before downloading them?

Thanks