Excel VBA - Automation Error

Question

I am trying to use macro that gets the list of the images and their dimension( Width/Height) in to spreadshit. When i execute macro it runs for few seconds and retrive 116 records out of 2000 images in folder and than just crashes with Automation error.

I have researched and tried to apply fixex i could find with updates, repoar office etc. and nothing is fixing this issue.

Public Sub Image()
Dim strFile As String
Dim stdPic As StdPicture
Dim lngWidth As Long
Dim lngHeight As Long
Dim strPath As String
Dim lngRow As Long ' Made this a Long just in case you have a LOT of pictures

strPath = "C:\IMAGES\"

' Get all files (we'll filter the results below)
'    strFile = Dir$(strPath & "\*.jpg")
     strFile = Dir$(strPath & "\*.*")

' Find the last row in Col A
lngRow = Range("A10000").End(xlUp).Row

Do While Len(strFile)
    ' Select the picture types you want. In this case jpg, bmp and png
    If UCase$(Right$(strFile, 4)) = ".JPG" Or _
       UCase$(Right$(strFile, 4)) = ".BMP" Or _
       UCase$(Right$(strFile, 4)) = ".PNG" Then
        Set stdPic = LoadPicture(strPath & "\" & strFile)
        lngRow = lngRow + 1
        Range("A" & lngRow).Value = strFile
        Range("B" & lngRow).Value = Round(stdPic.Width / 26.4583)
        Range("C" & lngRow).Value = Round(stdPic.Height / 26.4583)
    End If
    strFile = Dir$
Loop
End Sub

Anyone have idea why is this happening?

Answer 1

This should do the trick:

A few comments:

• Avoid double backslashes, you had it in strPath but also used it in the strFile assignment.
• If an image load failed it would error, we now clear stdPic, disable error handling, attempt to load stdPic, re-enable error handling, and check if stdPic exists to ensure the image properly loaded. If it didn't then it doesn't get an entry. When dealing with something that can go wrong and crash the sub it's best to check it has functioned as expected.

Amended sub below:

Public Sub Image()
Dim strFile As String
Dim stdPic As StdPicture
Dim lngWidth As Long
Dim lngHeight As Long
Dim strPath As String
Dim lngRow As Long ' Made this a Long just in case you have a LOT of pictures

strPath = "C:\IMAGES"

' Get all files (we'll filter the results below)
'    strFile = Dir$(strPath & "\*.jpg")
     strFile = Dir$(strPath & "\*.*")

' Find the last row in Col A
lngRow = Range("A10000").End(xlUp).Row

Do While Len(strFile)
    ' Select the picture types you want. In this case jpg, bmp and png
    If Left(strFile, 1) <> "~" And _
        (UCase$(Right$(strFile, 4)) = ".JPG" Or _
        UCase$(Right$(strFile, 4)) = ".BMP" Or _
        UCase$(Right$(strFile, 4)) = ".PNG") Then
            Set stdPic = Nothing
            On Error Resume Next
                Set stdPic = LoadPicture(strPath & "\" & strFile)
            On Error GoTo 0
            If Not stdPic Is Nothing Then
                lngRow = lngRow + 1
                Range("A" & lngRow).Value = strFile
                Range("B" & lngRow).Value = Round(stdPic.Width / 26.4583)
                Range("C" & lngRow).Value = Round(stdPic.Height / 26.4583)
            End If
    End If
    strFile = Dir$
Loop
End Sub