Internet - Picture - Download!

In column B on sheet1 is a list with hyperlink on pictures in the Internet as "http://www.yourside.com/sample.jpg". The following codes write either True/False in column C or load the picture into column C. The pictures are represented with 50x20 pixel. The pictures are copied temporarly into a folder and deleted then again. The folder is also deleted. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged in "Module1"

Option Explicit
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
Public Sub Internet_Picture()
Dim strFile As String
Dim strPath As String
Dim lngResult As Long
Dim lngLastRow As Long
Dim wksSheet As Worksheet
Dim shpPicture As Shape
Dim strURL As String
On Error GoTo Fin
Application.ScreenUpdating = False
Set wksSheet = ThisWorkbook.Worksheets("Sheet1") 'adapt
With wksSheet
lngLastRow = IIf(IsEmpty(.Range("B" & .Rows.Count)), _
.Range("B" & .Rows.Count).End(xlUp).Row, .Rows.Count)
If IsFilePath("C:\INET_Temp\") Then
strPath = "C:\INET_Temp\"
Else
MkDir "C:\INET_Temp\"
strPath = "C:\INET_Temp\"
End If
.Range(.Cells(1, 3), .Cells(lngLastRow, 3)).Clear
For Each shpPicture In ActiveSheet.Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Delete
End If
Next
For lngLastRow = 1 To lngLastRow
strURL = .Cells(lngLastRow, 2).Text
strFile = strPath & 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 = True
Else
.Cells(lngLastRow, 3).Value = False
End If
Kill strFile
Else
.Cells(lngLastRow, 3).Value = False
End If
Next
End With
Fin:
If IsFilePath("C:\INET_Temp\") Then Call FolDel
Application.ScreenUpdating = True
End Sub
Private Sub FolDel()
Dim ObjFSO As Object, strFilePath As String
strFilePath = "C:\INET_Temp"
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
ObjFSO.DeleteFolder strFilePath
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

The following code belonged In "Module2"

Option Explicit
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
Public Sub Internet_Picture_1()
Dim strFile As String
Dim strPath As String
Dim lngResult As Long
Dim lngLastRow As Long
Dim wksSheet As Worksheet
Dim strURL As String
Dim shpPicture As Shape
On Error GoTo Fin
Application.ScreenUpdating = False
Set wksSheet = ThisWorkbook.Worksheets("Sheet1") 'adapt
With wksSheet
lngLastRow = IIf(IsEmpty(.Range("B" & .Rows.Count)), _
.Range("B" & .Rows.Count).End(xlUp).Row, .Rows.Count)
If IsFilePath("C:\INET_Temp\") Then
strPath = "C:\INET_Temp\"
Else
MkDir "C:\INET_Temp\"
strPath = "C:\INET_Temp\"
End If
.Range(.Cells(1, 3), .Cells(lngLastRow, 3)).Clear
For Each shpPicture In ActiveSheet.Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Delete
End If
Next
For lngLastRow = 1 To lngLastRow
strURL = .Cells(lngLastRow, 2).Text
strFile = strPath & 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
With wksSheet.Shapes.AddPicture _
(strFile, False, True, 0, 0, 50, 20)
.Left = wksSheet.Cells(lngLastRow, 3).Left
.Top = wksSheet.Cells(lngLastRow, 3).Top
.Name = "picture" & lngLastRow
End With
Else
.Cells(lngLastRow, 3).Value = "No"
End If
Kill strFile
Else
.Cells(lngLastRow, 3).Value = "No file"
End If
Next
End With
Fin:
If IsFilePath("C:\INET_Temp\") Then Call FolDel
Application.ScreenUpdating = True
End Sub
Private Sub FolDel()
Dim ObjFSO As Object, strFilePath As String
strFilePath = "C:\INET_Temp"
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
ObjFSO.DeleteFolder strFilePath
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


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...