Error While Importing Images VBA

[titanunleashed]

Hi,
Please help resolve below error; I am using below mentioned VBA:



>>> use code - tags <<<

Sub Imager()
'
' Imager Macro
'
' Keyboard Shortcut: Ctrl+j
'
Dim fPath As String, fName As String
Dim r As Range, rng As Range
Dim shpPic As Shape

Application.ScreenUpdating = False
fPath = "D:\Images\"
Set rng = Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
For Each r In rng
    On Error GoTo errHandler
    If r.Value <> "" Then
        Set shpPic = ActiveSheet.Shapes.AddPicture(Filename:=fPath & r.Value & ".jpg", linktofile:=msoFalse, _
            savewithdocument:=msoTrue, Left:=Cells(r.Row, 2).Left, Top:=Cells(r.Row, 2).Top, Width:=-10, Height:=-10)
        With shpPic
            .LockAspectRatio = msoTrue
            If .Width > Columns(2).Width Then .Width = Columns(2).Width
            Rows(r.Row).RowHeight = .Height
        End With
    End If
errHandler:
If Err.Number <> 0 Then
    Debug.Print Err.Number & ", " & Err.Description & ", " & r.Value
    On Error GoTo -1
End If
Next r
Application.ScreenUpdating = True

End Sub

 

[Debaser]

Are you certain that file exists?

 

[titanunleashed]

Hi,
I am new to this. File does not exist. I just want to skip this error.
It's very irritating.

 

[Debaser]

Try something like this:

Sub Imager()
'
' Imager Macro
'
' Keyboard Shortcut: Ctrl+j
'
   Dim fPath As String
   Dim r As Range, rng As Range
  
   Application.ScreenUpdating = False
  
   fPath = "D:\Images\"
  
   Set rng = Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
  
   For Each r In rng
  
      If r.Value <> "" Then InsertPicture fPath & r.Value & ".jpg", r.Row, 2
      
   Next r
  
   Application.ScreenUpdating = True

End Sub
Sub InsertPicture(pictureFile As String, rwNum As Long, colNum As Long)
   Dim shpPic As Shape

   If Dir(pictureFile) <> vbNullString Then
      On Error Resume Next
      Set shpPic = ActiveSheet.Shapes.AddPicture(Filename:=pictureFile, linktofile:=msoFalse, _
      savewithdocument:=msoTrue, Left:=Cells(rwNum, colNum).Left, Top:=Cells(rwNum, colNum).Top, Width:=-10, Height:=-10)
      If shpPic Is Nothing Then
         Debug.Print Err.Number & ", " & Err.Description & ", " & pictureFile
         Err.Clear
      Else
         With shpPic
            .LockAspectRatio = msoTrue
            If .Width > Columns(colNum).Width Then .Width = Columns(colNum).Width
            Rows(rwNum).RowHeight = .Height
         End With
      End If
   End If

End Sub

 

[titanunleashed]

Thank You! Debaser.
It's Works now