Problem with OnError when insterting pictures

[cocopops2001]

I have a problem with an OnError statement within my code.

What I would like is for my code to run a loop and extract a filename using the information in columns 1 and 2 of specific range and then insert this picture into the last column of same range. This bit works fine.

If the file cannot be found then I would like the last column to say "No Photo Found". This partially works as the No Photo Found appears in row 2 of my range but from then on I get the error 'unable to get the Insert property of the Picture class'. I know this is because the file is not available but in this case it should be putting "No Photo Found" into the cell instead of the picture.

Code below. Any help would be great.

Sub RefreshList()
    Application.ScreenUpdating = False
    
    Range("B4").Select
    Selection.End(xlDown).Select
    EndRow = Selection.Row
    
    Range("B4:H" & EndRow).Select
      
    With Selection
        ActiveWorkbook.Names.Add Name:="StaffList", RefersTo:=Range("B4:H" & EndRow)
    End With
    
    With Range("Stafflist")
    .Rows(RowNum).RowHeight = 130#
    End With
       
    Range("H4").Select
    
    Range("H4:H" & EndRow).Select
      
    With Selection
        ActiveWorkbook.Names.Add Name:="PhotoRange", RefersTo:=Range("H4:H" & EndRow)
    End With
          
RowNum = 1
    
PicInsert:
Do While Range("stafflist").Cells(RowNum, 1) <> 0
    
'On Error GoTo ErrNoPhoto:
    Dim picname As String
     
    picname = Range("Stafflist").Cells(RowNum, 1) & " " & Range("Stafflist").Cells(RowNum, 2) 'This is the picture name
On Error GoTo ErrNoPhoto:
    ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & "_Photos\" & picname & ".jpg").Select 'Path to where pictures are stored
    
    With Selection
    .ShapeRange.LockAspectRatio = msoTrue
    .ShapeRange.Height = 120#
    .ShapeRange.Rotation = 0#
    .Top = Range("StaffList").Cells(RowNum, 7).Top
    .Left = Range("StaffList").Cells(RowNum, 7).Left
    .Placement = xlMoveAndSize
    .Name = picname
    End With
        
    RowNum = RowNum + 1
    
Loop
    
    Application.ScreenUpdating = True
    Exit Sub
ErrNoPhoto:
            
    Range("StaffList").Cells(RowNum, 7) = "No Photo Found"
    
    RowNum = RowNum + 1
        
    GoTo PicInsert
    
    Exit Sub
Application.ScreenUpdating = True
End Sub

 

[Jerry Sullivan]

Hi cocopops2001,

The code that you have should successfully place one "No Photo Found" for the first missing photo, then fail on the second missing photo.

The problem is that in VBA you can't handle an error that occurs within an error handler. When your code execution jumps to ErrNoPhoto:, VBA considers that you are "in an error handler". Even after jumping back to GoTo PicInsert, you would need to exit the error handler, for example with a Resume statement, to allow the error hander to be reset.

Your code should work if you replace

GoTo PicInsert 
   'with...
Resume PicInsert

Even though that will work, IMO a cleaner approach would be to test if the Picture was inserted instead of having an error handler and resume cause the execution of the code to jump within the procedure.

Here's one way to do that...

Sub RefreshList2()
    Dim EndRow As Long, RowNum As Long
    Dim picname As String, picFolder As String
    Dim pic As Picture
    
    With ActiveSheet
        EndRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        Range("B4:H" & EndRow).Name = "StaffList"
        Range("H4:H" & EndRow).Name = "PhotoRange"
    End With
    
    With ThisWorkbook
        'Path to where pictures are stored
        picFolder = .Path & "\" & _
            Left(.Name, InStr(.Name, ".") - 1) & "_Photos\"
    End With

    Application.ScreenUpdating = False

    With Range("Stafflist")
       .EntireRow.RowHeight = 130#
        For RowNum = 1 To .Rows.Count
            picname = .Cells(RowNum, 1) & " " & .Cells(RowNum, 2)
            On Error Resume Next
            Set pic = ActiveSheet.Pictures.Insert(picFolder _
                & picname & ".jpg")
            On Error GoTo 0
            If pic Is Nothing Then
                .Cells(RowNum, 7) = "No Photo Found"
            Else
                With pic
                    .ShapeRange.LockAspectRatio = msoTrue
                    .ShapeRange.Height = 120#
                    .ShapeRange.Rotation = 0#
                    .Top = Range("StaffList").Cells(RowNum, 7).Top
                    .Left = Range("StaffList").Cells(RowNum, 7).Left
                    .Placement = xlMoveAndSize
                    .Name = picname
                    Set pic = Nothing
                End With
            End If
        Next RowNum
    End With
    
    Application.ScreenUpdating = True
End Sub

 

[cocopops2001]

Thanks very much for this. I knew there was something wrong but just couldnt figure out what.

I also agree that the way you have written it is much cleaner.

 

[RoryA]

You could also use Dir to check if the file exists and only then try to insert it. Then you don't need an error handler at all.

 

[cocopops2001]

Rory,

Can you elaborate on this? I was checking through my SS and have found that there are multiple pictures in each cell which appear when the list is refreshed. it should only insert the one picture. ie skip the insertion if a pic exists.

 

[RoryA]

There is nothing in the code to test if there is already a picture 'in' a cell (pictures aren't actually contained in cells) - I was referring to having the code check if the image file existed before it tried adding it to the sheet. If you need to check whether there is already a picture located over the cell, you would have to loop through all the pictures and test the TopLeftCell property - was that what you meant?

 

[cocopops2001]

There is nothing in the code to test if there is already a picture 'in' a cell (pictures aren't actually contained in cells) - I was referring to having the code check if the image file existed before it tried adding it to the sheet. If you need to check whether there is already a picture located over the cell, you would have to loop through all the pictures and test the TopLeftCell property - was that what you meant?

More or less yes. Looping through the range is not a problem as I already have to loop through to find the pictures and insert them. I assume this will be a straighforward additional line within this loop to test. I havent ever used the TopLeftCell property before so how would I implment a check as to whether there is a pic there or not?

 

[RoryA]

Not one line - you basically have to loop through every picture for every cell, or perform one loop at the start to locate all the pictures and store their addresses so that you can then test as you loop through the range.
Is it OK to simply delete all the pictures at the start and then recreate them from the file information, or might some of the files have gone? Alternatively, if there are multiple pictures occupying the same cell, is it ok to just delete any duplicates (i.e. will they all be the same picture)?

 

[cocopops2001]

Not one line - you basically have to loop through every picture for every cell, or perform one loop at the start to locate all the pictures and store their addresses so that you can then test as you loop through the range.
Is it OK to simply delete all the pictures at the start and then recreate them from the file information, or might some of the files have gone? Alternatively, if there are multiple pictures occupying the same cell, is it ok to just delete any duplicates (i.e. will they all be the same picture)?

Rory,

Clearing the range and inputting the pictures every time is not exactly ideal but would probably be ok. What I am creating is a staff list which will add in a picture for each person (unless a picture cant be found). The only time a picture will change is if an updated photo is taken and replaces the existing. In this case the old photo should be deleted.

The list is approximately 150 people and I havent tested with the full amount. Only three sample pictures so deleting and inserting the whole list will depend on how quickly it runs when all the photos are added.

 

[RoryA]

Try this (air code):

Sub RefreshList()
   Dim EndRow                      As Long
   Dim RowNum                      As Long
   Dim sPicPath                    As String
   Dim picname                     As String
   Dim oPic                        As Shape

   Application.ScreenUpdating = False

   sPicPath = ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & "_Photos\"

   EndRow = Range("B4").End(xlDown).Row

   With Range("B4:H" & EndRow)
      .Name = "StaffList"
      .Rows(1).RowHeight = 130#
   End With

   ActiveSheet.Pictures.Delete
   Range("H4:H" & EndRow).Name = "PhotoRange"
   With Range("StaffList")

      For RowNum = 1 To .Cells.Count
         picname = .Cells(RowNum, 1) & " " & .Cells(RowNum, 2)   'This is the picture name

         If Dir(sPicPath & picname & ".jpg") = "" Then
            .Cells(RowNum, 7) = "No Photo Found"
         Else
            Set oPic = ActiveSheet.Shapes.AddPicture(sPicPath & picname & ".jpg")   'Path to where pictures are stored
            With oPic
               .LockAspectRatio = msoTrue
               .Height = 120#
               .Rotation = 0#
               .Top = Range("StaffList").Cells(RowNum, 7).Top
               .Left = Range("StaffList").Cells(RowNum, 7).Left
               .Placement = xlMoveAndSize
               .Name = picname
            End With
         End If

      Next RowNum

   End With

   Application.ScreenUpdating = True
End Sub