Retrieve image dimensions if it exists

[cindygo]

Hello –

Our team has been using an xls Marco to retrieve the files in a specific path provided by the user. There is a button on the sheet that runs the below Marco. This has been working perfectly for years however the new ask is for the Marco to return the image dimensions (as in 2189 x 1700) of the file if this information exists into column J of each row.

I have searched the web and this forum and have not been able to find something to add to this code to make this work.

Any advice on this would be very much appreciated.

Thanks for your help,
Cindy

Public gFileTypes As String
Public gCurrentRow As Integer
Public gCurrentIndent As Integer
Public gFileCount As Integer
Public gFolderCount As Integer
Public gGlobalPath As String
Public fs As Object
Sub GetFiles()
    Application.Cursor = xlWait
   
    Application.ScreenUpdating = False
    Call CleanUp
    ' Application.ScreenUpdating = True
   
    gFileCount = 0
    gFolderCount = 0
    Set fs = CreateObject("Scripting.FileSystemObject")
   
    ' Determine files to look for
    ' -------------------------------------------------------------------
    FileTypes = Range("FileTypes")
    FileTypes = Replace(FileTypes, " ", "")
    gFileTypes = FileTypes
   
    ' Clean up FolderName
    ' ------------------------------------------------------------------
    folderName = Range("FilePath")
    folderName = Replace(folderName, "/", "\")
    If Right(folderName, 1) = "\" Then folderName = Left(folderName, Len(folderName) - 1)
    Range("FilePath") = folderName
   
    gCurrentRow = 22
    gCurrentIndent = 0
    gGlobalPath = folderName
    Call DoFolder(gGlobalPath)
    Application.ScreenUpdating = False
    Call IndentRows
    Application.ScreenUpdating = True
    Range("files") = gFileCount
    Range("folders") = gFolderCount
    Range("A24").Select
   
    Application.Cursor = xlDefault
    Application.StatusBar = ""
    ActiveWindow.ScrollRow = 24
    'Worksheets("PivotTable").PivotTables("PivotTable1").PivotCache.Refresh
    Range("D" & CStr(CurrentRow) & ":" & "G" & CStr(CurrentRow)).Font.Name = "Arial"
    Range("D" & CStr(CurrentRow) & ":" & "G" & CStr(CurrentRow)).Font.Size = "8"
    Range("D" & CStr(CurrentRow) & ":" & "G" & CStr(CurrentRow)).HorizontalAlignment = xlLeft
    MsgBox "Finished searching. Scroll up to adjust settings" & Chr(13) & "or to search again.", vbOKOnly, "Done"
End Sub
 
Sub DoFolder(folderPath As String)
    gFolderCount = gFolderCount + 1
    Set folder = fs.GetFolder(folderPath)
    Set foldercontents = folder.Files
    For Each fileObject In foldercontents
        Filename = fileObject.Name
        Application.StatusBar = Filename
        ' Is this file what we're looking for?
        Extension = Right(Filename, 3)
        If InStr(Range("FileTypes"), Extension) <> 0 Or Range("FileTypes") = "*.*" Then
            gFileCount = gFileCount + 1
            With Range("C" & CStr(gCurrentRow))
                .Value = Filename
                .Select
                'Selection.InsertIndent gCurrentIndent + 1
            End With
            AbsolutePath = fileObject.Path
            RelativePath = Right(AbsolutePath, Len(AbsolutePath) - Len(gGlobalPath) - 1)
           
            Range("D" & CStr(gCurrentRow)).Value = AbsolutePath
            Range("E" & CStr(gCurrentRow)).Value = AbsolutePath
            Range("F" & CStr(gCurrentRow)).Value = fileObject.Size
            DateCreated = fileObject.DateCreated
            Range("G" & CStr(gCurrentRow)).Value = FormatDateTime(DateCreated, vbShortDate)
            DateModified = fileObject.DateLastModified
            Range("H" & CStr(gCurrentRow)).Value = FormatDateTime(DateModified, vbShortDate)
            Range("I" & CStr(gCurrentRow)).Value = fileObject.Type
 
           
            gCurrentRow = gCurrentRow + 1
        End If
    Next
   
    Set newFolderCollection = folder.subfolders
    For Each newFolder In newFolderCollection
        gCurrentIndent = gCurrentIndent + 1
        filePath = newFolder.Name
        With Range("C" & CStr(gCurrentRow))
            .Value = UCase(filePath)
            .Font.FontStyle = "Bold"
            .Select
            'Selection.InsertIndent gCurrentIndent
            gCurrentRow = gCurrentRow + 1
        End With
        DoFolder (folderPath & "/" & filePath)
        gCurrentIndent = gCurrentIndent - 1
    Next
   
End Sub
Sub CleanUp()
    Application.StatusBar = "Cleaning up..."
    CurrentCursor = Application.Cursor
    CurrentScreen = Application.ScreenUpdating
   
    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    CurrentRow = 25
    While Range("C" & CStr(CurrentRow)).Value <> ""
       Worksheets("Results").Rows(CurrentRow).Delete
    Wend
    CurrentRow = 2
    'While Range("PivotData!A" & CStr(CurrentRow)).Value <> ""
      ' Worksheets("PivotData").Rows(CurrentRow).Delete
    'Wend
   
    Application.StatusBar = ""
    Application.ScreenUpdating = CurrentScreen
    Application.Cursor = CurrentCursor
End Sub
Sub IndentRows()
    CurrentRow = 25
    While Range("C" & CStr(CurrentRow)).Value <> ""
        RowValue = CurrentRow
        'LevelValue = Range("C" & CStr(CurrentRow)).IndentLevel
        With Worksheets("Results")
            For i = 2 To LevelValue
                .Rows(CStr(RowValue)).Group
            Next
        End With
        CurrentRow = CurrentRow + 1
    Wend
    ActiveSheet.Outline.ShowLevels RowLevels:=1
End Sub
Sub RevertLinksToURLs()
    CurrentRow = 22
    Dim HL As Object
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
  
    While Range("C" & CStr(CurrentRow)).Value <> ""
        NumberOfLinks = Range("E" & CStr(CurrentRow)).Hyperlinks.Count
        If NumberOfLinks > 0 Then
       
            Set HL = Range("E" & CStr(CurrentRow)).Hyperlinks(1)
            Address = HL.Address
            HL.Delete
            Range("E" & CStr(CurrentRow)).Value = Address
 
       
            Range("E" & CStr(CurrentRow) & ":" & "E" & CStr(CurrentRow)).Font.Name = "Arial"
            Range("E" & CStr(CurrentRow) & ":" & "E" & CStr(CurrentRow)).Font.Size = "8"
            Range("E" & CStr(CurrentRow) & ":" & "E" & CStr(CurrentRow)).HorizontalAlignment = xlLeft
           
        End If
        CurrentRow = CurrentRow + 1
    Wend
    Application.Cursor = xlDefault
End Sub
 
Sub RevertURLstoLinks()
    CurrentRow = 22
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
   
    While Range("C" & CStr(CurrentRow)).Value <> ""
   
        If Range("E" & CStr(CurrentRow)).Value <> "" Then
       
            Range("E" & CStr(CurrentRow)).Select
            ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
            Range("E" & CStr(CurrentRow)), TextToDisplay:="Link"
 
           
        End If
        CurrentRow = CurrentRow + 1
    Wend
    Application.Cursor = xlDefault
End Sub

 

[John_w]

For retrieving image dimensions use the Microsoft Shell Controls and Automation class, specifically the GetDetailsOf method.

 

[cindygo]

Sorry for the delaying in responding.
Thanks John_w for your suggestion however I have tried to figure out how to use the GetDetailsof method to works for this but haven't had much luck. Can you provide an example?

Thanks again

 

[John_w]

Try something based on this code:

Sub Test()
    Dim Sh As Object
    Dim ShFolder As Object
    Dim ShFile As Object
    
    Set Sh = CreateObject("Shell.Application")
    Set ShFolder = Sh.Namespace("C:\Path\to\folder")   'CHANGE FOLDER PATH
    For Each ShFile In ShFolder.Items
        Debug.Print ShFile.Path, ShFile.Name, ShFolder.GetDetailsOf(ShFile, 26)
    Next
End Sub

As shown, you have to loop through the Shell Folder Items collection; you can't tell it to return the details of a specific file.

 

[cindygo]

Thanks John_w. I see that changing the ShFile.Name to ShFile.Type returns JPEG Image etc. However I need the image Dimensions. If I change ShFile.Name to ShFile.Dimensions I get a run time error 438. Object doesn't support this property or method. I've googled file properties but there is no mention of file Dimension.

Do you know how to get this data?

thanks again.
Cindy

 

[John_w]

Did you try my code? All you have to do is change the folder path in the code to the folder containing your image files. The 26 in ShFolder.GetDetailsOf(ShFile, 26) returns the image dimensions (e.g. "1280 x 960"), if the file is an image (.jpg, .png, etc.), therefore it's probably a good idea to check ShFile.Type to see if the file is an image. 27 returns the width ("1280 pixels") and 28 returns the height ("960 pixels").

 

[cindygo]

Yes I ran the code which is pointing to a list of image files, all jpegs. I tried changing the ShFile, 26 to 27 or 28. I also stepped through the code to but nowhere within the Immediate or Locals views did is display the dimensions, width or height.

 

[John_w]

The code works for me on Windows XP. Try this version which loops through GetDetailsOf columns 0 to 255 and outputs each property name and value. One of these should be the dimensions.

Sub Test2()
    Dim Sh As Object
    Dim ShFolder As Object
    Dim ShFile As Object
    Dim i As Integer
    
    Set Sh = CreateObject("Shell.Application")
    Set ShFolder = Sh.Namespace("C:\Path\to\folder")   'CHANGE FOLDER PATH
    For Each ShFile In ShFolder.Items
        Debug.Print ShFile.Path, ShFile.Name
        For i = 0 To 255
            Debug.Print i; ShFolder.GetDetailsOf(ShFolder.Items, i); " = "; ShFolder.GetDetailsOf(ShFile, i)
        Next
    Next
End Sub

 

[mvsub1]

I was reading along with this post and tried your code John_w.
In Windows 7 the number 31 returns the image dimensions (162 for width; 164 for height).

Thanks. Learned something new and interesting

 

[cindygo]

That works great. Thanks John_w!