VBA code to get picture dimensions & DPI from selectable folder and it's subfolders

M

Milen

New Member
Joined
Nov 6, 2023
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Hey all,

Hope you can help me with the below challenge I face:

I've got several folders with a lot of subfolders each, containing images (large majority is JPG, but there might be a few JPEGs, PNGs... ). Several users upload new images there all the time. So I am trying to get VBA to help me get overview on a regular basis of the dimensions & DPI for each image in a specific folder and all it's subfolders.

I've managed to make the below code to work quite satisfactory, but the issue is I can only get it to work in the folder I specify in the code.
Ideally I'd like when running the macro to get a prompt to select a folder for it to run into, and include all potential subfolders of the selected folder.

Please help?

I run W11, Microsoft 365 Apps for business. I'm really not that experienced with VBA, the below is a patched-together solution I've managed to make work from other posts. The currently given folder in the macro is just for tests :)
The output it gives me (and is quite satisfactory) is :
Column A - image name
Column B - image dimensions
Column C - Horizontal resolution
Column D - Vertical resolution

VBA Code: 
Sub Get_Dims_DPI()
    Dim sFile As Object
  
    'Create Shell Object & NameSpace
    Set oShell = CreateObject("Shell.Application")
    Set oDir = oShell.Namespace("C:\test_images")
    
    ActiveSheet.Cells.ClearContents
   
        Cells(1, 1).Value = oDir.GetDetailsOf(oDir, 0)
        Cells(1, 2).Value = oDir.GetDetailsOf(oDir, 31)
        Cells(1, 3).Value = oDir.GetDetailsOf(oDir, 175)
        Cells(1, 4).Value = oDir.GetDetailsOf(oDir, 177)
       
   
    'Loop thru each File/Folder inside Root Directory
    i = 2
   
   
    For Each sFile In oDir.Items
    Cells(i, 1).Value = oDir.GetDetailsOf(sFile, 0)
    Cells(i, 2).Value = oDir.GetDetailsOf(sFile, 31)
    Cells(i, 3).Value = oDir.GetDetailsOf(sFile, 175)
    Cells(i, 4).Value = oDir.GetDetailsOf(sFile, 177)
   
   
           i = i + 1
    Next
    MsgBox "Done"

End Sub
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
Hi Milen and Welcome to the Board! Seems like kind of a handy routine. You will need to adjust the sheet name to suit. To operate run the "Test" sub. HTH. Dave
Code: 
Sub test()
Dim Targetfolder As Object, FSO As Object, FolDir As Object, Ws As Worksheet
Set Ws = Sheets("Sheet1")
Ws.Cells.ClearContents
Set Targetfolder = Application.FileDialog(msoFileDialogFolderPicker)
With Targetfolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If Targetfolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
Call Get_Dims_DPI(FolDir, Ws)
Set FolDir = Nothing
Set FSO = Nothing
Set Targetfolder = Nothing
MsgBox "Done"
End Sub

Sub Get_Dims_DPI(FldObj, Ws As Worksheet)
Dim oShell As Object, SubFold As Object, oDir As Object
Dim sFile As Object, LastRow As Integer, i As Integer
'loop for subfolders
For Each SubFold In FldObj.SubFolders
Call Get_Dims_DPI(SubFold, Ws)
Next SubFold
    
    'Create Shell Object & NameSpace
    Set oDir = CreateObject("Scripting.FileSystemObject")
    Set oShell = CreateObject("Shell.Application")
    Set oDir = oShell.Namespace(FldObj.Path)
    
   With Ws
      LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
      If LastRow <> 1 Then
      LastRow = LastRow + 1
      End If
        .Cells(LastRow, 1).Value = oDir.GetDetailsOf(oDir, 0)
        .Cells(LastRow, 2).Value = oDir.GetDetailsOf(oDir, 31)
        .Cells(LastRow, 3).Value = oDir.GetDetailsOf(oDir, 175)
        .Cells(LastRow, 4).Value = oDir.GetDetailsOf(oDir, 177)
    'Loop thru each File/Folder inside Root Directory
    i = LastRow + 1
    For Each sFile In oDir.Items
    .Cells(i, 1).Value = oDir.GetDetailsOf(sFile, 0)
    .Cells(i, 2).Value = oDir.GetDetailsOf(sFile, 31)
    .Cells(i, 3).Value = oDir.GetDetailsOf(sFile, 175)
    .Cells(i, 4).Value = oDir.GetDetailsOf(sFile, 177)
    i = i + 1
    Next
    End With
Set oDir = Nothing
Set oShell = Nothing
End Sub
 
Upvote 1
Solution
Milen said:
I've managed to make the below code to work quite satisfactory, but the issue is I can only get it to work in the folder I specify in the code.
Ideally I'd like when running the macro to get a prompt to select a folder for it to run into, and include all potential subfolders of the selected folder.
Click to expand...

This code uses Application.FileDialog(msoFileDialogFolderPicker) to allow the user to select a folder and then calls a routine which lists the details of images in the folder and calls itself on each subfolder (a recursive procedure). It lists the full file path of the image file instead of the file name.

Most recursive subfolders code uses FileSystemObject, however I've used Microsoft Shell Controls and Automation (Shell32 or "Shell.Application") because your code already uses it.

VBA Code: 
Option Explicit

Public Sub List_Image_Details_In_Folders()

    Dim FDfolder As FileDialog
    Dim startFolderPath As String
    Dim oShell As Object 'Shell32.Shell
    Dim oDir As Object 'Shell32.folder
       
    Set FDfolder = Application.FileDialog(msoFileDialogFolderPicker)
   
    With FDfolder
        .Title = "Select Folder"
        .AllowMultiSelect = False
        If Not .Show Then Exit Sub
        startFolderPath = .SelectedItems(1) & "\"
    End With
           
    'Create Shell Object & NameSpace
    Set oShell = CreateObject("Shell.Application")
    Set oDir = oShell.Namespace(CVar(startFolderPath))
           
    With ActiveSheet
        .Cells.ClearContents
        .Range("A1:D1").Value = Array("Path", oDir.GetDetailsOf(oDir, 31), oDir.GetDetailsOf(oDir, 175), oDir.GetDetailsOf(oDir, 177))
        List_Image_Details_In_Folder oShell, startFolderPath, .Range("A2:D2")
    End With

End Sub


Private Sub List_Image_Details_In_Folder(Sh32 As Object, folderPath As String, destCell As Range)

    Dim ShFolder As Object 'Shell32.Folder
    Dim ShFolderItem As Object 'Shell32.FolderItem
    Dim r As Long
      
    Set ShFolder = Sh32.Namespace(CVar(folderPath))     'Must pass a Variant
   
    r = 0
    For Each ShFolderItem In ShFolder.Items
        If Not ShFolderItem.IsFolder Then
            destCell.Offset(r).Value = Array(ShFolderItem.Path, ShFolder.GetDetailsOf(ShFolderItem, 31), ShFolder.GetDetailsOf(ShFolderItem, 175), ShFolder.GetDetailsOf(ShFolderItem, 177))
            r = r + 1
        End If
    Next
   
    Set destCell = destCell.Offset(r)
   
    'Recursively loop through subfolders in this folder
    'ShFolderItem.path contains "\" if it is a Windows folder, otherwise it is a folder within a .zip file
   
    For Each ShFolderItem In ShFolder.Items
        If ShFolderItem.IsFolder And InStr(ShFolderItem.Path, "\") Then
            List_Image_Details_In_Folder Sh32, ShFolderItem.Path, destCell
        End If
    Next
           
End Sub
 
Last edited:
Upvote 1
Well John my bad. The sub at the bottom of your post didn't copy/paste for me. Of course it works fine. My apologies. Dave
 
Upvote 0
John_w said:
This code uses Application.FileDialog(msoFileDialogFolderPicker) to allow the user to select a folder and then calls a routine which lists the details of images in the folder and calls itself on each subfolder (a recursive procedure). It lists the full file path of the image file instead of the file name.

Most recursive subfolders code uses FileSystemObject, however I've used Microsoft Shell Controls and Automation (Shell32 or "Shell.Application") because your code already uses it.

VBA Code: 
Option Explicit

Public Sub List_Image_Details_In_Folders()

    Dim FDfolder As FileDialog
    Dim startFolderPath As String
    Dim oShell As Object 'Shell32.Shell
    Dim oDir As Object 'Shell32.folder
      
    Set FDfolder = Application.FileDialog(msoFileDialogFolderPicker)
  
    With FDfolder
        .Title = "Select Folder"
        .AllowMultiSelect = False
        If Not .Show Then Exit Sub
        startFolderPath = .SelectedItems(1) & "\"
    End With
          
    'Create Shell Object & NameSpace
    Set oShell = CreateObject("Shell.Application")
    Set oDir = oShell.Namespace(CVar(startFolderPath))
          
    With ActiveSheet
        .Cells.ClearContents
        .Range("A1:D1").Value = Array("Path", oDir.GetDetailsOf(oDir, 31), oDir.GetDetailsOf(oDir, 175), oDir.GetDetailsOf(oDir, 177))
        List_Image_Details_In_Folder oShell, startFolderPath, .Range("A2:D2")
    End With

End Sub


Private Sub List_Image_Details_In_Folder(Sh32 As Object, folderPath As String, destCell As Range)

    Dim ShFolder As Object 'Shell32.Folder
    Dim ShFolderItem As Object 'Shell32.FolderItem
    Dim r As Long
     
    Set ShFolder = Sh32.Namespace(CVar(folderPath))     'Must pass a Variant
  
    r = 0
    For Each ShFolderItem In ShFolder.Items
        If Not ShFolderItem.IsFolder Then
            destCell.Offset(r).Value = Array(ShFolderItem.Path, ShFolder.GetDetailsOf(ShFolderItem, 31), ShFolder.GetDetailsOf(ShFolderItem, 175), ShFolder.GetDetailsOf(ShFolderItem, 177))
            r = r + 1
        End If
    Next
  
    Set destCell = destCell.Offset(r)
  
    'Recursively loop through subfolders in this folder
    'ShFolderItem.path contains "\" if it is a Windows folder, otherwise it is a folder within a .zip file
  
    For Each ShFolderItem In ShFolder.Items
        If ShFolderItem.IsFolder And InStr(ShFolderItem.Path, "\") Then
            List_Image_Details_In_Folder Sh32, ShFolderItem.Path, destCell
        End If
    Next
          
End Sub
Click to expand...
Hey John,

Thank you for the help with this! File path instead of file name is no biggie - I can formulae/macro my way to name only :)
Unfortunately it seems it's not retrieving info for all files (file path yes, but no dimension, resolution). No fault of your excellent code itself, I suspect it's because I tried it on a dropbox shared folder.
This is a complete shot in the dark, but is there a way for VBA to "force-retrieve" the file details, or to force file explorer to retrieve the info.
To be clear - the folders are set as available offline, so I'm also investigating with Dropbox what's causing this. But maybe VBA has it's own trick up it's sleve? :D One can hope...

At any rate - cheers for the help, really appreciated! :)
 
Upvote 0
NdNoviceHlp said:
Hi Milen and Welcome to the Board! Seems like kind of a handy routine. You will need to adjust the sheet name to suit. To operate run the "Test" sub. HTH. Dave
Code: 
Sub test()
Dim Targetfolder As Object, FSO As Object, FolDir As Object, Ws As Worksheet
Set Ws = Sheets("Sheet1")
Ws.Cells.ClearContents
Set Targetfolder = Application.FileDialog(msoFileDialogFolderPicker)
With Targetfolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If Targetfolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
Call Get_Dims_DPI(FolDir, Ws)
Set FolDir = Nothing
Set FSO = Nothing
Set Targetfolder = Nothing
MsgBox "Done"
End Sub

Sub Get_Dims_DPI(FldObj, Ws As Worksheet)
Dim oShell As Object, SubFold As Object, oDir As Object
Dim sFile As Object, LastRow As Integer, i As Integer
'loop for subfolders
For Each SubFold In FldObj.SubFolders
Call Get_Dims_DPI(SubFold, Ws)
Next SubFold
   
    'Create Shell Object & NameSpace
    Set oDir = CreateObject("Scripting.FileSystemObject")
    Set oShell = CreateObject("Shell.Application")
    Set oDir = oShell.Namespace(FldObj.Path)
   
   With Ws
      LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
      If LastRow <> 1 Then
      LastRow = LastRow + 1
      End If
        .Cells(LastRow, 1).Value = oDir.GetDetailsOf(oDir, 0)
        .Cells(LastRow, 2).Value = oDir.GetDetailsOf(oDir, 31)
        .Cells(LastRow, 3).Value = oDir.GetDetailsOf(oDir, 175)
        .Cells(LastRow, 4).Value = oDir.GetDetailsOf(oDir, 177)
    'Loop thru each File/Folder inside Root Directory
    i = LastRow + 1
    For Each sFile In oDir.Items
    .Cells(i, 1).Value = oDir.GetDetailsOf(sFile, 0)
    .Cells(i, 2).Value = oDir.GetDetailsOf(sFile, 31)
    .Cells(i, 3).Value = oDir.GetDetailsOf(sFile, 175)
    .Cells(i, 4).Value = oDir.GetDetailsOf(sFile, 177)
    i = i + 1
    Next
    End With
Set oDir = Nothing
Set oShell = Nothing
End Sub
Click to expand...
Hey Dave,

Thank you and thanks for your awesome suggestion! Seems to be working fantastically. Alas - not retrieving the dimensions/resolutions of all listed files, due to them being in a dropbox shared folder. The foldes/files are set of available offline, but something apparently isn't synching properly. Do you know (if at all possible?!?) for VBA to force-retrieve this info or force file explorer to retrieve it? This is obviously a cloud synch issue, and I am investigating with Dropbox what's causing it - but maybe you know of a VBA trick/workaround? :)

Thanks a lot for your help at any rate - it's really appreciated!
 
Upvote 0
Hi Millen. You could trial copying the whole folder from the dropbox folder to your local drive and then retrieve them from your local drive. Something like this...
Code: 
Dim OfsObj As Object
Set OfsObj = CreateObject("Scripting.FilesystemObject")
If OfsObj.folderexists("C:\LocalFolderName") = True Then
OfsObj.deletefolder ("C:\LocalFolderName")
Application.Wait (Now + TimeValue("0:00:01"))
End If
OfsObj.CopyFolder SHareFolderPath, "C:\LocalFolderName", True
Set OfsObj = Nothing
Good luck. Dave
 
Upvote 1
You must log in or register to reply here.

Similar threads

M
  • Question
VBA search for specific file name in folders and their subfolders
Replies
7
Views
839
Candyman8019
C
S
  • Solved
For each row, create new folder based on single cell value, then save exported XML doc to matching folder.
Replies
3
Views
176
shand
S
B
  • Solved
VBA macro to copy files from one folder (and all it's subfolders, and their subfolders, and their subfolders with an exception....) to another folder?
Replies
4
Views
704
Bering
B
KlausW
  • Question
browse to folders and subfolders an copy cell
Replies
0
Views
195
KlausW
KlausW
C
  • Solved
VBA listing folders, sub-folders & file names - modification required
Replies
5
Views
408
NdNoviceHlp
NdNoviceHlp

Forum statistics

Threads
1,215,076
Messages
6,122,988
Members
449,093
Latest member
Mr Hughes

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top