Excel 2010 VBA Picture Imports - Please help me expand on this code...

[Bret1]

The code below allows me to input a complete picture file name into cell (A2), press the “Refresh” control button, and the picture from the file name is displayed. Each time the “Refresh” button is clicked, it clears the current picture and refreshes the picture from the file name referenced in cell (A2). It also corrects for “Non-existent file name” errors.

I would like to add 2 things to the code:
1 - Allow for a “File Description” name to display in place of the actual “File Name”.
2 - Allow for multiple file name pictures to be displayed.
I would like the ability to select any cell, and click an “Add Picture” control button. Then a pop-up displays requesting “File Name?” and “File Description?”. After completing and selecting “OK”, the “File Description” is displayed in the active cell, and the top left corner of the picture from the file is displayed under the cell. Each time the “Refresh” button is clicked, the pictures are cleared and refreshed from the reference file names to eliminate having multiple layers of hidden pictures.

Thanks for any help!

Here is the code I have that allows for one picture to display from the full file name given in cell (A2)…

 Private Sub cmdDisplayPhoto_Click()Application.ScreenUpdating = False
Dim myObj
Dim Pictur
Set myObj = ActiveSheet.DrawingObjects
For Each Pictur In myObj
If Left(Pictur.Name, 7) = "Picture" Then
Pictur.Select
Pictur.Delete
End If
Next
 
Dim PictureName As String
PictureName = Range("A2")
 
On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=PictureName, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=190, Top:=30, Width:=300, Height:=300
 
errormessage:
If Err.Number = 1004 Then
MsgBox "File does not exist." & vbCrLf & "Check the filename again"
Range("A2").Value = ""
 
End If
Application.ScreenUpdating = True
End Sub

 

[Bret1]

Worf,
Thank you VERY much for working on this! Sorry for the delay getting back. It's been a crazy busy week.
This is getting very close to what I had imagined. However, it appears that the very long (300+ character) file names are still causing errors.
When I apply short file names it seems to work. But the very long file names gives the following error...
Run-time error '-2147024809(80070057)':
The specified file is out of range.

Is there any way around this?
Also, whenever I do use short file names and click the "Refresh" button, it does not delete the current pictures before refreshing them... so it can get multiple layers.

Thanks!
Bret

 

[Bret1]

I'm no programmer, but just had an idea....
Would it possibly work?
Highlight a cell and click "Add picture" button. Fill in "text-box long file name" as reference to picture link and "short name" for cell description.
After "ok".... The short description name would be placed into the active cell, and the long file name "text box" reference could be put BEHIND the picture just under the short name cell. Then the actual picture could be put on top of the "text box" file reference. When "Refresh button is pushed, the "text box" references are unchanged, but the pictures from them are deleted and refreshed.

In order for me to move around/re-organize the pictures. Their locations could be dependent upon where the "short description" names are placed. The "text-box long file name and pictures always in the cell under "short description" cell. Maybe the short description cells could be referenced with "**" before them or something so the program would know that's a "short description" name cell and the text-box file reference and file picture goes just below it.

Thanks again!

 

[Bret1]

I was just playing around with WORD and EXCEL hyperlink options. That option allows you to copy in a long hyperlink name destination and a short description name to appear in the cell - just like I want to do. Of course, the draw back is that Excel limits the number of characters for the hyperlink destination. However, WORD apparently does not. And I found that if I create a hyperlink in WORD with "over the limit characters" and copy the hyperlink over to Excel, it will except the full hyperlink name. Could that be a work around?

I could just copy over the hyperlinks to Excel sheet that way, and maybe have Excel just look for the hyperlinks to the web-based picture files and import the pictures right below the hyperlink descriptions.

 

[Worf]

Hi Bret

o Windows has a maximum path length of 260 characters, I was testing with short local paths.
o I’m understanding that you are using URLs
o The following code worked for me with a short URL. Please test it again with an actual big path of yours and tell me what happens. If it does not work, one possible solution could be to shrink it by using a tool such as Google URL Shortener.

Sub PictureGrabber()
    With ActiveSheet.Pictures
        .Insert ("http://www.dogbreedinfo.com/images26/PugPurebredDogFawnBlackMax8YearsOld1.jpg")
    End With
End Sub

 

[Worf]

Also, the hyperlink option seems interesting. Could you send me a huge URL image address you are using for my own testing?

 

[Worf]

Hi Bret
- I tested the insert method with a 302 character URL and it worked
- Please test the new routine below; I will return tomorrow with the refresh code.

Private Sub Add_HLink_Picture_Click()               ' add picture


Dim ac As Range, fnc$, fd$, ash As Worksheet, nh%
Set ac = ActiveCell
fnc = Application.InputBox("Enter image address cell" & vbLf & _
"This cell will become a hyperlink", "Example input: D4", "d4", , , , 2)
fd = Application.InputBox("Enter image description:", , , , , , 2)
Set ash = ActiveSheet
ash.Hyperlinks.Add Range(fnc), Range(fnc).Value
nh = ash.Hyperlinks.Count


With ash.Pictures.Insert(ash.Hyperlinks(nh).Address)
    .Name = "hli" & nh
    .Left = ac.Left     ' positions at active cell
    .Top = ac.Top
    .Width = 200
    .Height = 150
End With
ash.Hyperlinks(nh).ScreenTip = ac.Address   ' store information
ac.Offset(-1) = fd      ' short description


End Sub

 

[Bret1]

I was able to import multiple pictures from multiple picture inks with this code!
On this method though, I have to paste the very long URLs on the page. Which will eventually clog up the page.
I am curious how the "refresh" button will work.... Since there is no specific cell location given in the code for the long URL file, how will it know what cells to reference to refresh the pictures?
That's why I was hoping I could use the Hyperlink option (even if I have to copy it over from WORD because of the URL lengths). If you can get the code to render the image from a hyperlink and put the picture just below the hyperlink cell..... Then when refreshed, it could just delete all the pictures, and wherever there is a hyperlink on the the page, it would render that picture just below it from the URL within the short hyperlink name. It would not be necessary to have a secondary "very long" list of URLs somewhere to reference since they would be "built into" the hyperlink short name.

Also with that method, I could easily delete a picture and move the hyperlink somewhere else on the page. When refreshed, the code looks for the hyperlink and renders the picture just below it.

So far though, I have not had any luck rendering a picture from an actual hyperlink.

 

[Worf]

Hi
Here is the complete code. Would you like to have the long URLs on a separate sheet?

Private Sub Add_HLink_Picture_Click()               ' add picture
Dim ac As Range, fnc$, fd$, ash As Worksheet, nh%
Set ac = ActiveCell
fnc = Application.InputBox("Enter image address cell" & vbLf & _
"This cell will become a hyperlink", "Example input: D4", "d4", , , , 2)
fd = Application.InputBox("Enter image description:", , , , , , 2)
Set ash = ActiveSheet
ash.Hyperlinks.Add Range(fnc), Range(fnc).Value
nh = ash.Hyperlinks.Count
With ash.Pictures.Insert(ash.Hyperlinks(nh).Address)
    .Name = "hli" & nh
    .Left = ac.Left     ' positions at active cell
    .Top = ac.Top
    .Width = 200
    .Height = 150
End With
ash.Hyperlinks(nh).ScreenTip = ac.Address   ' store information
ac.Offset(-1) = fd      ' short description
End Sub


Private Sub CommandButton22_Click()     ' refresh pictures
Dim sh As Shape, h As Hyperlink, i%, a As Worksheet
Set a = ActiveSheet
For Each sh In a.Shapes
    If sh.Name Like "hli*" Then sh.Delete
Next
For i = 1 To a.Hyperlinks.Count
    Set h = a.Hyperlinks(i)
    With a.Pictures.Insert(h.Address)
        .Name = "hli" & i
        .Left = Range(h.ScreenTip).Left ' same location as before
        .Top = Range(h.ScreenTip).Top
        .Width = 200
        .Height = 150
    End With
Next
End Sub

 

[Bret1]

Everything seems to be working great!
It would be great if the long URLs could be put on a separate "Long URLs" sheet.
Also, I noticed that even if I move a picture, it repopulates back to its original location after refreshing. Would it be possible to make the pictures repopulate to their last location if moved? That way I can re-allocate the pictures around the page as needed.
I will be able test it more later tonight and tomorrow evening.
Thanks again!

 

[Worf]

Hi
Please test this new version:

Private Sub Add_HLink_Picture_Click()               ' add picture
Dim ac As Range, fnc$, fd$, ash As Worksheet, nh%, url As Worksheet


Set url = Sheets("Long URLs")   ' where URLs are
fnc = Application.InputBox("Enter image address cell" & vbLf & _
"This cell will become a hyperlink", "Example input: D4", "d4", , , , 2)
fd = Application.InputBox("Enter image description:", , , , , , 2)
Set ash = Sheets("Sheet1")
url.Hyperlinks.Add url.Range(fnc), url.Range(fnc).Value
nh = url.Hyperlinks.Count
Set ac = ActiveCell
With ash.Pictures.Insert(url.Hyperlinks(nh).Address)
    .Name = "hli" & nh
    .Left = ac.Left     ' positions at active cell
    .Top = ac.Top
    .Width = 200
    .Height = 150
End With
ac.Offset(-1) = fd      ' short description
End Sub


Private Sub Refresh_Click()     ' repopulates to last location
Dim sh As Shape, h As Hyperlink, i%, ash As Worksheet, url As Worksheet
Set url = Sheets("Long URLs")
Set ash = Sheets("Sheet1")    ' where the pictures are


For Each sh In ash.Shapes
    If sh.Name Like "hli*" Then
        url.Hyperlinks(CInt(Split(sh.Name, "i")(1))).ScreenTip = sh.TopLeftCell.Address
        sh.Delete
    End If
Next
Application.ScreenUpdating = True
MsgBox "pictures deleted.", 64, "For testing purposes"
For i = 1 To url.Hyperlinks.Count
    Set h = url.Hyperlinks(i)
    With ash.Pictures.Insert(h.Address)
        .Name = "hli" & i
        .Left = ash.Range(h.ScreenTip).Left
        .Top = ash.Range(h.ScreenTip).Top
        .Width = 200
        .Height = 150
    End With
Next
End Sub