Graphic Getter and Code Creator

Hi, all! I haven't been here in sooooo long (since April 29th).

Of course, I'm only here 'cause I want something.

In the attached sample file, I have 3 columns.

Column A: I want this to be the image that's in the folder.
Column B: I want this to be the file name that's in the folder, and corresponds with the image.
Column C: I'll create a formula that makes a string for img tags JUST like the ones used here.

I'll need a command button or a double-click on image or something like that that copies the string to the user's clipboard.

I was going to use a drawn object 'cause I like the ability to move them around, but we have enough images that we'll need to scroll through the list of images to choose one, and I can't make the drawn object sit still.

The chat room that this goes with doesn't have a nice display method for the smilies like this forum does.

Thanks in advance for all your help!

xxxooo

Do you want to insert the picture or insert it as a link to make the file smaller?

For the picture shape, do you want to set a constant height or width to resize to? Some pictures are large so that would make sense. I recommend setting one dimension like height and letting the other scale to size as needed.

Another tweak might be to set the filename with a hyperlink so that it can be opened for full viewing.

What type of pictures did you want to insert, jpg, bmp, gif, etc.?

The code might go something like:
[VBA]Sub AddMyPics()
Dim picsPath As String, fn As String, dpfn As String
Dim r As Range, s As Shape

'Set folder name that contains JPG picture files.
picsPath = "c:\myfiles\excel\pics\"

'End if picPath does not exist.
If Dir(picsPath, vbDirectory) <> "." Then
MsgBox "Folder Does Not Exist:" & vbCrLf & picsPath, vbCritical, "Macro Ending"
Exit Sub
End If

'Set initial cell to start adding pictures and info.
Set r = Range("A2")

'Iterate through the JPG picture files.
fn = Dir(picsPath & "*.jpg")
Do While fn <> ""
'36 points = 1/2"
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 = ActiveSheet.Shapes.AddPicture(dpfn, msoTrue, msoFalse, .Left, .Top, 36, 36)
'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 & """'"
fn = Dir
Set r = .Offset(1, 0)
End With
Loop
End Sub

Sub ShowInfo(sInfo As String)
MsgBox sInfo
End Sub[/VBA]

I'm sorry! I didn't realize my old email address was still on this account. Thanks, Kenneth! I'll try it out.

To answer your questions, it'd be a "graphic picker", so I have to SEE the graphics. I don't care if they're linked or not, I just care that they'll update.
Ditto the size. It's fine putting them all at the same size.

I do not understand why I cannot copy the code?

Nevermind. It worked this time. Wonder what that was about...

Good Lord. I just re-read my original request. It completely sucks. I'm so sorry.

For one, the path to the image folder is online. http://www.12stepme.org

For two, the files could be jpg or png or gif or bmp.

LOL..... Very unlike you Anne

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]

Ken... sorry to take so long responding. This is a beautiful thing you got here! Mind if I take yet more of your time?

If I want the smilies to import at half the size, do I change the row/column measures? Or is the graphic size somewhere else?

Seriously. I can't thank you enough. This is WAY cool!

IS there a filename part or a file extension part that would define the half size that you want? If not, would it be based on the dimensions of the graphic file? I have used command line switches in IRFanView to get graphic size information. There may be an API method that could do it.

The size of the graphic is set in:
[VBA]Set AddPictureUrl = ActiveSheet.Shapes.AddPicture(sLocalFile, msoFalse, msoTrue, picR.Left, picR.Top, 36, 36) [/VBA]

The size of the cell is set in:
[VBA].RowHeight = 36
.ColumnWidth = 6 '6 would be the 36 point. A1 changed to Pic rather than Graphic.[/VBA]

I would just, for instance, not want any of them to be more than say 19 px high. Width...I don't care.

I'm going to try... picR.Top, 18, 18)

Thanks!

Okay, this:

[vba]"<img src=" & fn & ">"[/vba]

Creates a code like this:

<img src=2inlove.gif>

I need:

[vba](img)http://www.12stepme.org/smilies/2inlove.gif(/img)[/vba]

Except the parentheses need to be square brackets.

[VBA].Offset(0, 2).Value = "[img]" & pdfn & "[/img]" [/VBA]