Count images larger than a give size in a folder with vba

[kelly mort]

Hello again,

I have been searching the net for a while now to find a solution to my problem.

I have come close in most cases but not right to the point.

I want to go to a folder called "MyImages" in the location on my workbook. That's. ..... ThisWorkbook.Path & "\MyImages".

Then I count all images that are above 50kb and show results in a MsgBox alert.

Basically the images will be jpeg files but I will be glad if we can track all other image formats as well.

Thanks

 

[Jaafar Tribak]

See if you can adapt this code ;
https://stackoverflow.com/questions/41305586/looping-through-different-kinds-of-files-in-folder-vba

 

[kelly mort]

I have seen the code, tried setting

FolderPath = ThisWorkbook.Path & "\MyImages"

Then when I run it, it does not.

It looks like the macro is not available.

I can seem to figure out why

 

[Jaafar Tribak]

Actually, after taken a propper look at that routine, I found that it is not correct because it is recursive and the variables are lost .

Here is a better approach that uses a recursive FUNCTION instead of SUB and also should return all images file types :

In a Standard Module:

Option Explicit

Type FOUND_FILES
    FilesList() As String
    FilesCount As Long
End Type

Function GetImageFiles(FolderPath As String, MinFileSize As Double, Optional ByVal NewSearch As Boolean = True) As FOUND_FILES

    'define variables
    Dim fso As Object
    Dim objFolder As Object
    Dim objFolders As Object
    Dim objF As Object
    Dim objFile As Object
    Dim objFiles As Object
    Dim strFileName As String
    
    Static lFileCount As Long
    Static arImages() As String

    'set file system object
    Set fso = CreateObject("Scripting.FileSystemObject")

    'set folder object
    Set objFolder = fso.GetFolder(FolderPath)

    'set files
    Set objFiles = objFolder.Files
    Set objFolders = objFolder.subfolders

    'list all images in folder
    For Each objFile In objFiles
        If InStr(1, ".jpeg.jpg.bmp.png.tiff.raw", Split(objFile.Name, ".")(UBound(Split(objFile.Name, "."))), vbTextCompare) Then
            If objFile.Size >= MinFileSize Then
                strFileName = objFile.Name
                ReDim Preserve arImages(lFileCount)
                arImages(lFileCount) = strFileName
                lFileCount = lFileCount + 1
            End If
        End If
    Next

    'go through all subflders
    For Each objF In objFolders
        Call GetImageFiles(objF.Path, MinFileSize, False)
    Next

    GetImageFiles.FilesList = arImages()
    GetImageFiles.FilesCount = lFileCount
    
    'clear static variables for the next new search.
    If NewSearch Then
        lFileCount = 0
        Erase arImages
    End If
    
    Set objFolder = Nothing
    Set objFile = Nothing
    Set fso = Nothing

End Function

Test example:

Sub Test()

    Dim tFoundFiles As FOUND_FILES
    Dim element As Variant
    Dim sMyList As String
    Dim sFolderPath As String
    
    sFolderPath = ThisWorkbook.Path & "\MyImages\"
    If Len(Dir(sFolderPath)) Then
        tFoundFiles = GetImageFiles(FolderPath:=sFolderPath, MinFileSize:=50000)
        If tFoundFiles.FilesCount Then
            For Each element In tFoundFiles.FilesList
                sMyList = sMyList & "*" & element & vbNewLine
            Next element
            sMyList = "Image Files found : " & tFoundFiles.FilesCount & vbNewLine & vbNewLine & sMyList
            MsgBox sMyList
        Else
            MsgBox "Path :'" & sFolderPath & "' Has no file images with the specified criteria."
        End If
    Else
        MsgBox "Path :'" & sFolderPath & "' not found!"
    End If


End Sub

 

[kelly mort]

Actually, after taken a propper look at that routine, I found that it is not correct because it is recursive and the variables are lost .

Here is a better approach that uses a recursive FUNCTION instead of SUB and also should return all images file types :

In a Standard Module:

Option Explicit

Type FOUND_FILES
    FilesList() As String
    FilesCount As Long
End Type

Function GetImageFiles(FolderPath As String, MinFileSize As Double, Optional ByVal NewSearch As Boolean = True) As FOUND_FILES

    'define variables
    Dim fso As Object
    Dim objFolder As Object
    Dim objFolders As Object
    Dim objF As Object
    Dim objFile As Object
    Dim objFiles As Object
    Dim strFileName As String
    
    Static lFileCount As Long
    Static arImages() As String

    'set file system object
    Set fso = CreateObject("Scripting.FileSystemObject")

    'set folder object
    Set objFolder = fso.GetFolder(FolderPath)

    'set files
    Set objFiles = objFolder.Files
    Set objFolders = objFolder.subfolders

    'list all images in folder
    For Each objFile In objFiles
        If InStr(1, ".jpeg.jpg.bmp.png.tiff.raw", Split(objFile.Name, ".")(UBound(Split(objFile.Name, "."))), vbTextCompare) Then
            If objFile.Size >= MinFileSize Then
                strFileName = objFile.Name
                ReDim Preserve arImages(lFileCount)
                arImages(lFileCount) = strFileName
                lFileCount = lFileCount + 1
            End If
        End If
    Next

    'go through all subflders
    For Each objF In objFolders
        Call GetImageFiles(objF.Path, MinFileSize, False)
    Next

    GetImageFiles.FilesList = arImages()
    GetImageFiles.FilesCount = lFileCount
    
    'clear static variables for the next new search.
    If NewSearch Then
        lFileCount = 0
        Erase arImages
    End If
    
    Set objFolder = Nothing
    Set objFile = Nothing
    Set fso = Nothing

End Function

Test example:

Sub Test()

    Dim tFoundFiles As FOUND_FILES
    Dim element As Variant
    Dim sMyList As String
    Dim sFolderPath As String
    
    sFolderPath = ThisWorkbook.Path & "\MyImages\"
    If Len(Dir(sFolderPath)) Then
        tFoundFiles = GetImageFiles(FolderPath:=sFolderPath, MinFileSize:=50000)
        If tFoundFiles.FilesCount Then
            For Each element In tFoundFiles.FilesList
                sMyList = sMyList & "*" & element & vbNewLine
            Next element
            sMyList = "Image Files found : " & tFoundFiles.FilesCount & vbNewLine & vbNewLine & sMyList
            MsgBox sMyList
        Else
            MsgBox "Path :'" & sFolderPath & "' Has no file images with the specified criteria."
        End If
    Else
        MsgBox "Path :'" & sFolderPath & "' not found!"
    End If


End Sub

Great!


Thanks so much for your time .

It's working great.


I am learning from this forum and I appreciate that.


Edit:::

What's the difference between

My path

FolderPath = ThisWorkbook.Path & "\MyImages"


And yours?
FolderPath = ThisWorkbook.Path & "\MyImages"

I am confused

 

[Jaafar Tribak]

Please, ignore the previous function and use this more flexible & versatile which takes a new optional argument for searching subfolders (By default, the function doesn't search subfolders):

Option Explicit

Type FOUND_FILES
    FilesList() As String
    FilesCount As Long
End Type

Function GetImageFiles(ByVal FolderPath As String, Optional ByVal SearchSubFolders As Boolean = False, Optional ByVal MinFileSize As Double, Optional ByVal NewSearch As Boolean = True) As FOUND_FILES

    'define variables
    Dim fso As Object
    Dim objFolder As Object
    Dim objFolders As Object
    Dim objF As Object
    Dim objFile As Object
    Dim objFiles As Object
    Dim strFilePath As String
    Dim strFileName As String

    Static lFileCount As Long
    Static arImages() As String

    'set file system object
    Set fso = CreateObject("Scripting.FileSystemObject")

    'set folder object
    Set objFolder = fso.GetFolder(FolderPath)

    'set files
    Set objFiles = objFolder.Files
    Set objFolders = objFolder.subfolders

    'list all images in folder
    For Each objFile In objFiles
        If InStr(1, ".jpeg.jpg.bmp.png.tiff.raw", Split(objFile.Name, ".")(UBound(Split(objFile.Name, "."))), vbTextCompare) Then
            If objFile.Size >= MinFileSize Then
                strFilePath = objFile.Path
                strFileName = objFile.Name
                ReDim Preserve arImages(lFileCount)
                arImages(lFileCount) = strFilePath & strFileName
                lFileCount = lFileCount + 1
            End If
        End If
    Next

    'go through all subflders
    If SearchSubFolders Then
        For Each objF In objFolders
            Call GetImageFiles(objF.Path, False, MinFileSize, False)
        Next
    End If

    GetImageFiles.FilesList = arImages()
    GetImageFiles.FilesCount = lFileCount
    
    'clear static variables for the next new search.
    If NewSearch Then
        lFileCount = 0
        Erase arImages
    End If
    
    Set objFolder = Nothing
    Set objFile = Nothing
    Set fso = Nothing

End Function

Test example:

Sub Test()

    Dim tFoundFiles As FOUND_FILES
    Dim element As Variant
    Dim sMyList As String
    Dim sFolderPath As String
    
    sFolderPath = ThisWorkbook.Path & "\MyImages\"
    
    If Len(Dir(sFolderPath)) Then
        tFoundFiles = GetImageFiles(FolderPath:=sFolderPath, SearchSubFolders:=True, MinFileSize:=50000)
        If tFoundFiles.FilesCount Then
            For Each element In tFoundFiles.FilesList
                sMyList = sMyList & "*" & element & vbNewLine & vbNewLine
            Next element
            sMyList = "Total Image Files found : " & tFoundFiles.FilesCount & vbNewLine & vbNewLine & sMyList
            Debug.Print sMyList
            MsgBox sMyList
        Else
            MsgBox "Path :'" & sFolderPath & "' Has no file images with the specified criteria."
        End If
    Else
        MsgBox "Path :'" & sFolderPath & "' not found!"
    End If


End Sub

What's the difference between

My path

FolderPath = ThisWorkbook.Path & "\MyImages"


And yours?
FolderPath = ThisWorkbook.Path & "\MyImages"

I am confused

I don't see any difference.

Late Edit:
I see what you mean, the last Anti-Slash character is required when using the Dir function so the string passed to it is recognized as a folder

 

[kelly mort]

Okay nice.


I was talking about that last back slash "" in your path.

It failed to show while I posted.

 

[Jaafar Tribak]

Okay nice.


I was talking about that last back slash "" in your path.

It failed to show while I posted.

Let me explain :

Because in the Test routine I use the Dir function, this requires that I add a back slash at the end of the folder path otherwise the Dir Function will not recognize the string passed to it as a folder.

In fact, it is better to add Application.PathSeparator instead of the back slash so that the code also works on other operating systems other than windows where the Folder separator happens to be different than a back slash ( like in a Mac machine where I believe the path separator is :)

So the following is more correct:

sFolderPath = ThisWorkbook.Path & "\MyImages" & Application.PathSeparator

Probably a better way is to pass vbDirectory in the second argument of the Dir function so it explicitly tells the Dir function that we mean a folder.

Something like this should work whether you add a back slash at the end or not :

    sFolderPath = ThisWorkbook.Path & "\MyImages"
    If Len(Dir(sFolderPath, [B][COLOR=#ff0000]vbDirectory[/COLOR][/B])) Then
       [COLOR=#008000]'rest of your code .....[/COLOR]

 

[kelly mort]

Okay well understood.

Which means that it is time for me to review my codes for possible updates.

In that case will this:

sFolderPath = ThisWorkbook.Path & "\MyImages"
    If Len(Dir(sFolderPath, [B][COLOR=#ff0000]vbDirectory[/COLOR][/B])) Then
       [COLOR=#008000]'rest of your code .[/COLOR]

Do the work of the application.pathSeparator?


Making it run on other systems as well?

 

[Jaafar Tribak]

Okay well understood.

Making it run on other systems as well?

Yes. ....Adding vbDirectory should work fine accross different OS(s) with or without adding Application.PathSeparator

BTW, don't use the first code . Instead use the second code in post #6