VBA Code to list all files in a folder and also image dimensions

Question

I have the below code which lists all the file names (minus file extension) and also the image dimensions - don't get me wrong, it works, but it takes a couple of hours to list the file names and dimensions for 1,100 png images. I just wondered if there was any quicker way in which to do this? I'm not sure how to go about it in all honesty.

Sub Get_Properties_Men()
    Dim sFile As Variant
    Dim oShell As Object, oDir As Object
    Dim i As Long
    
    Set oShell = CreateObject("Shell.Application")
    Set oDir = oShell.Namespace("W:\Gegenpress Graphics\-- Crests Master\Clubs")
    i = 4
    For Each sFile In oDir.Items
        Cells(i, 1).Value = sFile.Name
        Cells(i, 2).Value = sFile.ExtendedProperty("Dimensions")
        i = i + 1
    Next
    
    Set oShell = CreateObject("Shell.Application")
    Set oDir = oShell.Namespace("W:\Gegenpress Graphics\-- Crests Master\Competitions")
    i = 4
    For Each sFile In oDir.Items
        Cells(i, 4).Value = sFile.Name
        Cells(i, 5).Value = sFile.ExtendedProperty("Dimensions")
        i = i + 1
    Next
    
    MsgBox "Men's crests and competitions added."
End Sub

Answer 1

It is obvious that your problem is related to the way of reading the folder drive. This should be a matter of network connection speed, but there are two issues which will improve the the code efficiency, respectively:

1. Writing to times per each iteration consumes time and Excel resources. So, placing the return in arrays and drop their content at the end will save some time.

2. Using early bounding allows "the compiler to make important optimizations that yield more efficient applications. Early-bound objects are significantly faster than late-bound objects and make your code easier to read and maintain by stating exactly what kind of objects are being used". Besides that, you also benefit of the intellisense suggestions... See here what Microsoft states on the issue.

A. The next piece of code automatically adds a reference to 'Microsoft Shell Controls and Automation`:

Private Sub addShell32Ref()
  'Microsoft Shell Controls and Automation`...
   On Error Resume Next
    ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\SysWOW64\Shell32.dll"
    If err.number = 32813 Then
        MsgBox "The reference already exists..."
    Else
        MsgBox "The reference added sucressfully..."
    End If
  On Error GoTo 0
End Sub

B. The next adapted code uses the two suggested ways to optimize its speed:

Sub Get_Properties_Men()
    'it needs a reference to 'Microsoft Shell Controls and Automation`...
    Dim oShell As Shell32.shell, oDir  As Shell32.Folder, sFile As Shell32.FolderItem
    
    Dim i As Long, arr1, arr2
    
    Set oShell = New Shell32.shell
    Set oDir = oShell.NameSpace("W:\Gegenpress Graphics\-- Crests Master\Clubs")
     
    ReDim arr1(1 To oDir.Items.count, 1 To 2) 'redim the array to keep the necessary data
    
    i = 1
    For Each sFile In oDir.Items
        arr1(i, 1) = sFile.Name
        arr1(i, 2) = sFile.ExtendedProperty("Dimensions")
        i = i + 1
    Next
    
    'you can use the same oShell object:
    Set oDir = oShell.NameSpace("W:\Gegenpress Graphics\-- Crests Master\Competitions")

    ReDim arr2(1 To oDir.Items.count, 1 To 2)
    i = 1
    For Each sFile In oDir.Items
        arr2(i, 1) = sFile.Name
        arr2(i, 2) = sFile.ExtendedProperty("Dimensions")
        i = i + 1
    Next
    
    'drop the loaded arrays content, at once:
    Range("A4").Resize(UBound(arr1), UBound(arr1, 2)).Value = arr1
    Range("D4").Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2
    
    MsgBox "Men's crests and competitions added."
End Sub

I cannot imagine how much it will increase the code speed, but certainly it will do something...

Please, send some feedback after testing it. It will maybe be good to also compare the return in case of the files moved on local. I mean, using your existing code and this adapted one...