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