Internet - Dateien - Download - Hyperlink setzen

Frage: In einem Tabellenblatt habe ich eine Liste mit Adressen von Bildern im Internet. Diese möchte ich auf meine Festplatte kopieren und eine Spalte neben der Adresse als Hyperlink einfügen. Wie geht das?

Hier noch eine Beispieldatei: Internet - Picture - Download

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