insert picture by VBA

[EMASOFT]

greetings
i have a spread sheet displaying photos on a square shape basing on cell contents on a drop down cell value at A1
my desire is to have all photos fitting into the size of the shape and if a name from A1 does not have a corresponding photo in the folder, then a blank image should display for that particular name
however part of my code is






Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False

Dim myPict As Picture
Dim PictureLoc As String

If Target.Address = Range("U13").Address Then

ActiveSheet.Pictures.Delete

PictureLoc = "C:\Users\EMASOFT\Desktop\PHOTO\" & Range("A1").Text & ".jpg"

With Range("P2")
On Error GoTo errormessage:
Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)

myPict.Height = 100
myPict.Width = 100
myPict.Top = .Top
myPict.Left = .Left
myPict.Placement = xlMoveAndSize
myPict.ShapeRange.LockAspectRatio = msoTrue

errormessage:
If Err.Number = 1004 Then

MsgBox "File does not Exist, Please first update photo with .jpg File"

End If
End With
End If
Application.ScreenUpdating = True
End Sub

 

[rlv01]

Welcome to Mr. Excel.
Possibly something like this.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    
    Dim myPict As Picture
    Dim PictureLoc As String, BlankPictureLoc As String
    
    If Target.Address = Range("U13").Address Then
        ActiveSheet.Pictures.Delete
        
        PictureLoc = "C:\Users\EMASOFT\Desktop\PHOTO\" & Range("A1").Text & ".jpg"
        BlankPictureLoc = "C:\Users\EMASOFT\Desktop\PHOTO\BlanksPicture.jpg"          '<--------------- Blank image file. You must edit!
        
        With CreateObject("Scripting.FileSystemObject")
            If Not .FileExists(PictureLoc) Then
                MsgBox "File does not Exist, Using blank image"
                PictureLoc = BlankPictureLoc
                
                If .FileExists(PictureLoc) Then
                    With Range("P2")
                        Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
                        myPict.Height = 100
                        myPict.Width = 100
                        myPict.Top = .Top
                        myPict.Left = .Left
                        myPict.Placement = xlMoveAndSize
                        myPict.ShapeRange.LockAspectRatio = msoTrue
                        Application.ScreenUpdating = True
                    End With
                End If
            Else
                MsgBox "File '" & PictureLoc & "' does not exist", vbCritical, "Blank Image Failure"
            End If
        End With
    End If
                    
  Application.ScreenUpdating = True
End Sub

(Tip: For future posts , please try to use code tags like I did above when posting code. It makes your code easier to read and copy.

How to Post Your VBA Code

Post your VBA code.

www.mrexcel.com

)