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]

Just a thought....Go back and take a look at the code on my very first post on the first line "screenupdating = false". I pretty much created that code from a Youtube video, but I think I remember him saying he put that line in so it would not auto-update?

 

[Worf]

Screen updating is related to screen refreshing. Try File>Options>Advanced>Calculation and verify if “update links to other documents” is checked or not.

 

[Worf]

Also Advanced>General> and check "Ask to update automatic links"

 

[Bret1]

Both are checked

 

[Worf]

Hi
- Uncheck the option mentioned at post #32 and see if it makes any difference
- The following add code is working, I’ll be back later with the rest.

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


' at Long URLs sheet:      column P = hyperlink cell       column Q = pic name
'column R = description     column S = pic position


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
lr = url.Range("p" & Rows.Count).End(xlUp).Row + 1
url.Cells(lr, 16) = fnc
url.Cells(lr, 18) = fd
url.Cells(lr, 19) = ActiveCell.Address
With ash.Pictures.Insert(url.Hyperlinks(url.Hyperlinks.Count).Address)
    .Name = "hli" & Date & Time
    .Left = ActiveCell.Left     ' positions at active cell
    .Top = ActiveCell.Top
    .Width = 200
    .Height = 150
    url.Cells(lr, 17) = .Name
End With
ActiveCell.Offset(-1) = fd      ' short description
End Sub

 

[Bret1]

Working with the last "full" version, I tried and found 2 things that may or may not help.....
I unchecked the “update links to other documents” tab, saved, closed and re-opened document. It still auto-refreshed at open, but when I looked at the “update links to other documents” tab again, it was "checked" again. So my "unchecking" apparently is not sticking.

Also, starting with a fresh, clean sheet, I linked to 2 pictures from my .../pictures directory and added them in. Something I noticed was that one of the pictures was tall/skinny and the other wasn't (which was correct for the pictures). However, then I saved and closed and switched the names in .../pictures directory. When I re-opened the document, it auto-refreshed and switched them, but it did not update the sizes of them. Picture 1 was originally on left and skinny.... picture 2 on right and wide
after switching in directory and re-opening with auto-refresh....
Picture 1 was on right wide and Picture 2 was on left and skinny.
After manual refresh, the sizes corrected.
I just wanted to bring this up since the sizes weren't auto-refreshing, maybe something from that could be applied to the pictures auto-refreshing.

 

[Worf]

Thanks for the information, I’ll see if it helps. Meanwhile, here is a new full version to deal with the link deleting scenario, note that now there is a table at the long URL sheet.

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


' at Long URLs sheet:      column P = hyperlink cell       column Q = pic name
'column R = description     column S = pic position        column T = link name


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
lr = url.Range("p" & Rows.Count).End(xlUp).Row + 1
url.Cells(lr, 16) = fnc
url.Cells(lr, 18) = fd
url.Cells(lr, 19) = ActiveCell.Address
With ash.Pictures.Insert(url.Hyperlinks(url.Hyperlinks.Count).Address)
    .Name = "hli" & Date & Time
    .Left = ActiveCell.Left     ' positions at active cell
    .Top = ActiveCell.Top
    .Width = 200
    .Height = 150
    url.Cells(lr, 17) = .Name
    url.Cells(lr, 20) = url.Hyperlinks(url.Hyperlinks.Count).Name
End With
ActiveCell.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, r As Range


Set url = Sheets("Long URLs")   ' first row at P-T with headers
Set ash = Sheets("Sheet1")    ' where the pictures are
For Each sh In ash.Shapes
    If sh.Name Like "hli*" Then
        Set r = url.Range("q:q").Find(sh.Name, [q1], xlValues)
        If r Is Nothing Then
            MsgBox "Could not find " & sh.Name
            Exit Sub
        End If
        r.Offset(, 2) = sh.TopLeftCell.Address
        sh.Delete
    End If
Next
Application.ScreenUpdating = True
MsgBox "pictures deleted.", 64, "For testing purposes"
For i = 2 To url.Range("p" & Rows.Count).End(xlUp).Row  ' refreshes based on table at P-T
    If Len(url.Cells(i, 16)) > 0 Then
        If url.Range(CStr(url.Cells(i, 16).Value)) <> "" Then
            With ash.Pictures.Insert((CStr(url.Cells(i, 20))))
                .Name = url.Cells(i, 17)
                .Left = ash.Range(url.Cells(i, 19)).Left
                .Top = ash.Range(url.Cells(i, 19)).Top
                ash.Range(.TopLeftCell.Address).Offset(-1) = url.Cells(i, 18)
                .Width = 200
                .Height = 150
            End With
        End If
    End If
Next
End Sub

 

[Worf]

See if this makes the options stick:

' this code goes at ThisWorkbook module


Private Sub Workbook_BeforeClose(Cancel As Boolean)


Me.UpdateLinks = xlUpdateLinksNever
Me.UpdateRemoteReferences = False
Application.AskToUpdateLinks = True


End Sub


Private Sub Workbook_Open()


Me.UpdateLinks = xlUpdateLinksNever
Me.UpdateRemoteReferences = False
Application.AskToUpdateLinks = True


End Sub