-
Attached is a 2010 xls.
Run the AddMyPics() in mMain. It inserts image shapes of about 0.5" by 0.5" starting at A3 of the current sheet. Change the starting range if needed. Change the height and width in the AddPictureURL() routine if needed. Add extra file extensions as needed.
The two modules of note are mMain and mAPI. Some of the mAPI could be removed and cleaned up a bit.
mMain:
[vba]Sub AddMyPics()
Dim picsPath As String, fn As String, dpfn As String
Dim r As Range, s As Shape, t As String
Dim a() As String, i As Integer
Dim d As Object
'Set folder name that contains JPG picture files.
picsPath = "http://www.12stepme.org/images/"
'Set dictionary of file extensions.
Set d = CreateObject("Scripting.Dictionary")
d.Add "gif", "gif"
d.Add "jpg", "jpg"
d.Add "png", "png"
d.Add "tif", "tif"
d.Add "bmp", "bmp"
'Get source text of web page in picsPath.
a() = SourceText(picsPath)
'Set initial cell to start adding pictures and info.
Set r = Range("A3")
'Iterate through the picture files from the url's source text.
For i = 0 To UBound(a)
t = CStr(a(i))
If InStr(t, """") = 13 Then
fn = Mid(t, 14, InStrRev(t, """") - 14)
If Not d.exists(LCase(Right(fn, 3))) Then GoTo NextI
With r
.RowHeight = 36
.ColumnWidth = 6 '6 would be the 36 point. A1 changed to Pic rather than Graphic.
dpfn = picsPath & fn
.Offset(0, 1).Value = dpfn
Range(r, .Offset(0, 2)).HorizontalAlignment = xlGeneral
Range(r, .Offset(0, 2)).VerticalAlignment = xlCenter
'*** Modify as needed below for the ImgTags.
.Offset(0, 2).Value = "<img src=" & fn & ">"
'AutoFit Columns B and C.
Range("B:C").Columns.AutoFit
Set s = AddPictureUrl(dpfn, fn, r)
'Rename picture shape's name to be fn.
s.Name = fn
'Set a macro to play when picture shape is clicked.
s.OnAction = "'ShowInfo """ & dpfn & """'"
Set r = .Offset(1, 0)
End With
End If
NextI:
Next i
Set d = Nothing
Set r = Nothing
End Sub
Function SourceText(Url As String)
Dim Request As Object, s As String, a() As String, i As String
Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
Request.Open "GET", Url, False
Request.Send
s = Request.ResponseText
'Debug.Print s
a() = Split(s, vbLf)
Set Request = Nothing
SourceText = a()
End Function
Sub ShowInfo(sInfo As String)
MsgBox sInfo
End Sub
[/vba]
mAPI:
[vba]
'http://vbnet.mvps.org/index.html?code/internet/urldownloadtofilenocache.htm
'http://www.mrexcel.com/forum/showthread.php?t=116387
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
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias _
"GetTempFileNameA" (ByVal lpszPath As String, _
ByVal lpPrefixString As String, ByVal wUnique As Long, _
ByVal lpTempFileName As String) As Long
Private Declare Function SetFileAttributes Lib "kernel32" Alias _
"SetFileAttributesA" (ByVal lpFileName As String, _
ByVal dwFileAttributes As Long) As Long
Private Const ERROR_SUCCESS As Long = 0
Private Const BINDF_GETNEWESTVERSION As Long = &H10
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Function DownloadFile(sSourceURl As String, _
sLocalFile As String) As Boolean
'Dim sLocalFile As String
'Download the file. BINDF_GETNEWESTVERSION forces
'the API to download from the specified source.
'Passing 0& as dwReserved causes the locally-cached
'copy to be downloaded, if available. If the API
'returns ERROR_SUCCESS (0), DownloadFile returns True.
DownloadFile = URLDownloadToFile(0&, _
sSourceURl, _
sLocalFile, _
BINDF_GETNEWESTVERSION, _
0&) = ERROR_SUCCESS
End Function
'Tweak of LoadPictureUrl() by Kenneth Hobson, 9/27/10
Function AddPictureUrl(sSourceURl As String, sFilename As String, picR As Range) As Shape
Dim sLocalFile As String, s As Shape, tf As Boolean
On Error GoTo err_h
'Create a temp filename.
sLocalFile = Environ("temp") & "\" & sFilename
'Set the file attributes
SetFileAttributes sLocalFile, FILE_ATTRIBUTE_TEMPORARY
'Attempt to delete any cached version of the file.
DeleteUrlCacheEntry sSourceURl
'Delete temp file if it exits.
If Dir(sLocalFile) <> "" Then Kill sLocalFile
tf = DownloadFile(sSourceURl, sLocalFile)
'While Not (tf)
'DoEvents
'Wend
If tf = True Then
Set AddPictureUrl = ActiveSheet.Shapes.AddPicture(sLocalFile, msoFalse, msoTrue, picR.Left, picR.Top, 36, 36)
Kill sLocalFile
Else
'Create a bogus error
Err.Raise 999
End If
Exit Function
err_h:
Set AddPictureUrl = Nothing
End Function[/vba]
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules