Counting files in a folder

[smithr8]

Ken Duls posted this code sometime back and it looks beautiful. Unfortunately, no that Application.FileSearch is gone it doesn't work. This is exactly what I'm trying to do now in Excel 2013.

I want to build a formula in a workbook that will display the current number of files within a folder as a way of showing how much paperwork has yet to be processed.



Option Compare Text
Option Explicit

Function CountFiles(Directory As String, Optional Ext As String = "All") As Double
'Function purpose: To count all the files in a directory
'Alternate purpose: To count all files in a directory with a specified file extension

'Method: If a file extension is supplied as an arguement, we can cut down on the list
' of files to filter through by calling only files that are in the same
' msoFileType group. (ie .doc and .dot files belong to the WordDocuments
' group, but not the ExcelWorkbooks group. This will allow us to count the
' number of files matching the extension more quickly, since we will only
' operate on files that belong to that group, not all groups. If no file
' extension is supplied (or the file does not belong to any specified group,)
' we can still resort to counting all files.

Dim fs As Object, i As Integer

'Create the FileSearch object
Set fs = Application.FileSearch

'If an empty string has been passed as the file extension, set it to "All"
If Len(Ext) < 3 Then Ext = "All"

With fs
'Set the directory to look in to the directory arguement supplied by the user
.LookIn = Directory
'Determine the msoFileType group that the file extension belongs to.
.FileType = GetMSOFileType(Ext)
'Execute the search
.Execute

If Ext = "All" Then
'If no file extension supplied, count all files in the directory
CountFiles = .FoundFiles.count
Else
'If a file extension is supplied count the number of files in the
'filtered list which match the supplied extension
For i = 1 To .FoundFiles.count
If Right(.FoundFiles.Item(i), 3) = Right(Ext, 3) Then _
CountFiles = CountFiles + 1
Next i
End If
End With

'Release the FileSearch object
Set fs = Nothing

End Function

Function GetMSOFileType(FileExt As String) As Double
'Function purpose: To determine the msoFileType of a file extension
'Note: If a file extension does not exist in the list, the file type will default
' to AllFiles. More msoFileTypes can be found by looking up the "FileType Property"
' in the VBA help, or on Sheet2 of the example workbook

Select Case Right(FileExt, 3)
Case Is = "doc", "dot"
'Assign file type of msoFileTypeWordDocuments
'NOTE: msoFileTypeWordDocuments does not include "rtf" files
GetMSOFileType = 3
Case Is = "xls", "xla", "xlt", "xlc", "xlm"
'Assign file type of msoFileTypeExcelWorkbooks
'NOTE: msoFileTypeExcelWorkbooks does not include "xll" or "xlw" files
GetMSOFileType = 4
Case Is = "ppt", "pps", "pot"
'Assign file type of msoFileTypePowerPointPresentations
GetMSOFileType = 5
Case Is = "mdb", "mde", "ade", "adp"
'Assign file type of msoFileTypeDatabases
'NOTE: msoFileTypeDatabases does not include "mda" files
GetMSOFileType = 7
Case Is = "pub"
'If XL2002 or later, assign file type of msoFileTypePublisherFiles
'otherwise, assign file type of msoFileTypeAllFiles
If Val(Application.Version) < 10 Then
GetMSOFileType = 1
Else
GetMSOFileType = 18
End If
Case Is = "vsd", "vss", "vst"
'If XL2002 or later, assign file type of msoFileTypeVisioFiles
'otherwise, assign file type of msoFileTypeAllFiles
'NOTE: msoFileTypeVisioFiles does not include "vsw", "vdx", "vsx" or "vtx" files
If Val(Application.Version) < 10 Then
GetMSOFileType = 1
Else
GetMSOFileType = 21
End If
Case Is = "htm", "tml", "mht"
'If XL2002 or later, assign file type of msoFileTypeWebPages
'otherwise, assign file type of msoFileTypeAllFiles
If Val(Application.Version) < 10 Then
GetMSOFileType = 1
Else
GetMSOFileType = 23
End If
Case Else
'Assign file type of msoFileTypeAllFiles
GetMSOFileType = 1
End Select

End Function

[mancubus]

welcome to vbax.

please use code tags when posting your code.

the # button will do it for you.

when you click the button [ CODE ]paste_your_code_here[/CODE ] tags will be inserted. paste your code in between these tags.

that said check below KB article (by Ken Puls)

http://www.vbaexpress.com/kb/getarticle.php?kb_id=238

[smithr8]

Thanks for both the code tags pointer and the link to the updated post.

The updated code works perfectly. One thing I noticed though is that it counts all file types (including hidden .db files) which will be a nuisance to me the way I'd like use this.

1. Is there a way to have the code count specific file types?

[snb]

sub M_snb()
c00="G:\OF\" ' foldername
c01="*.pdf" ' file extension

msgbox ubound(split(createobject("wscript.shell").exec("cmd /c Dir """ & c00 & c01 & """ /b").stdout.readall,vbCrLf))
End Sub

[Paul_Hossler]

You can play with this -- I'm not sure what / how you want to count specific file types, but this way wildcards work




Option Explicit
Sub drv()

MsgBox CountFilesInFolder("c:\users\daddy\test")
MsgBox CountFilesInFolder("c:\users\daddy\test\bupc*")
MsgBox CountFilesInFolder("c:\users\daddy\test\*.txt")

End Sub

Function CountFilesInFolder(sFolder As String) As Long


Dim oFSO As Object, oRegExp As Object, oFile As Object
Dim sSearchFolderName As String, sFileName As String
Dim iFileCount As Long

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oRegExp = CreateObject("vbscript.RegExp")

If oFSO.FolderExists(sFolder) Then ' sFolder is a directory, list all files in sFolder
sSearchFolderName = sFolder
sFileName = ""
Else
sSearchFolderName = oFSO.GetParentFolderName(sFolder)
sFileName = oFSO.GetFileName(sFolder)
oRegExp.Global = True
oRegExp.Pattern = "\."
sFileName = oRegExp.Replace(sFileName, "\.")
oRegExp.Pattern = "\?"
sFileName = oRegExp.Replace(sFileName, ".")
oRegExp.Pattern = "\*"
sFileName = oRegExp.Replace(sFileName, ".*")
End If
With oRegExp
.Pattern = sFileName
.IgnoreCase = True
.Global = False
End With
iFileCount = 0
For Each oFile In oFSO.GetFolder(sSearchFolderName).Files
If oRegExp.Test(oFile.Name) Then
If (oFile.Attributes And vbHidden) = vbHidden Then GoTo NextFile
If (oFile.Attributes And vbSystem) = vbSystem Then GoTo NextFile
iFileCount = iFileCount + 1
End If
NextFile:
Next

CountFilesInFolder = iFileCount
End Function

[smithr8]

Paul, this solution is amazing! Thank you!

[Kenneth Hobs]

FSO methods is what most use to replace Application.FileSearch. If you like that method, try using an alternative class as I detailed in this thread. http://www.vbaexpress.com/forum/showthread.php?49603-Application-FileSearch-in-Office-2010

It will do most of what Application.FileSearch does but in the end, it also uses FSO. The advantage is that with just a bit of effort, the old ways can be used mostly.

[GTO]

Just another try; in this case, Excel 32-bit is required...


Option Explicit

Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const MAX_PATH As Long = 260
Private Const FILE_ATTRIBUTE_READONLY As Long = &H1
Private Const FILE_ATTRIBUTE_HIDDEN As Long = &H2
Private Const FILE_ATTRIBUTE_SYSTEM As Long = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800
Private Const FILE_ATTRIBUTE_ALL As Long = FILE_ATTRIBUTE_READONLY Or _
FILE_ATTRIBUTE_HIDDEN Or _
FILE_ATTRIBUTE_SYSTEM Or _
FILE_ATTRIBUTE_ARCHIVE Or _
FILE_ATTRIBUTE_NORMAL

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long

Public Function RetFileCounts(StartPath As String)
#Const XL64 = Win64

#If XL64 Then '<--- Is Excel 64-bit? (Not really asking about Windows)

RetFileCounts = "64 bit, I need decalred functions changed"
#Else
Dim MyReturn As Variant
Dim n As Long
Dim sMsg As String
Dim Total As Long
MyReturn = FileCountsReturn(StartPath)

If IsArray(MyReturn) Then
For n = 1 To UBound(MyReturn)
sMsg = sMsg & MyReturn(n, 1) & ":" & Space(6 - Len(MyReturn(n, 1))) & MyReturn(n, 2) & vbLf
Total = Total + MyReturn(n, 2)
Next
sMsg = sMsg & "Total = " & Total
Else
sMsg = MyReturn
End If

RetFileCounts = sMsg

#End If
End Function

Private Function FileCountsReturn(ByVal Path As String) As Variant
Dim DIC As Object '<--- Scripting.Dictionary
Dim WFD As WIN32_FIND_DATA
Dim hwndFile As Long
Dim sCleanName As String
Dim arr As Variant
Dim Keys As Variant
Dim n As Long

Path = PathFixed(Path) & "*.*"

hwndFile = FindFirstFile(Path, WFD)

If Not hwndFile = INVALID_HANDLE_VALUE Then

Set DIC = CreateObject("Scripting.Dictionary")
Do
If Not (WFD.dwFileAttributes And vbDirectory) = FILE_ATTRIBUTE_DIRECTORY Then
sCleanName = TrimNull(WFD.cFileName)
sCleanName = LCase$(Mid$(sCleanName, InStrRev(sCleanName, ".")))
If DIC.Exists(sCleanName) Then
DIC.Item(sCleanName) = CLng(DIC.Item(sCleanName)) + 1
Else
DIC.Item(sCleanName) = 1
End If
End If
Loop Until FindNextFile(hwndFile, WFD) = 0&

If DIC.Count > 0 Then

If DIC.Count = 1 Then
ReDim arr(1 To 1, 1 To 2)
arr(1, 1) = DIC.Keys(0)
arr(1, 2) = DIC.Items(0)
FileCountsReturn = arr
Else
arr = Application.Transpose(DIC.Keys)
Keys = Application.Transpose(DIC.Items)
ReDim Preserve arr(1 To UBound(arr), 1 To 2)

For n = 1 To UBound(arr)
arr(n, 2) = Keys(n, 1)
Next

FileCountsReturn = arr
End If
Else
FileCountsReturn = "No files found"
End If
Else
FileCountsReturn = "No files found"
End If
End Function

Private Function TrimNull(startstr As String) As String
TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
End Function

Private Function PathFixed(ByVal Path As String) As String
Do While Right$(Path, 1) = "\"
Path = Left$(Path, Len(Path) - 1)
Loop
PathFixed = Path & "\"
End Function


Hope that helps,

Mark

[Paul_Hossler]

Paul, this solution is amazing! Thank you!

NP - it's based roughly on some code I found with Google

I modified some VB Script code I use to build an array of matching path names for a WSH script, so a little tweaking into VBA was easy

I like it because IMHO it's simple to follow and to use (and modify when needed)

[apo]

I posted some code for something very similar in another forum just the other day for a person called CobraLAD.. are you him the same person?

Anyway.. try this.. using Forfiles gets around one of DIR's resultant characteristics..

Example: It will return *.xlsm and *.xlsx files when *.xls is asked for..

Although.. I am pretty sure Forfiles is slower than DIR to complete..

Add the /S switch to go through subfolders as well..


Private Sub CommandButton1_Click()
Dim fldr As FileDialog, SelFold As String, ExtVal As String, ShortName As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
If .Show <> -1 Then Exit Sub
SelFold = .SelectedItems(1)
End With
ExtVal = InputBox("File Extension including wildcard and period." & vbLf & "Example: *.xls", "Enter File Extension")
ShortName = CreateObject("Scripting.FileSystemObject").GetFolder(SelFold).ShortName
MsgBox "File Count: " & UBound(Filter(Split(Replace(CreateObject("wscript.shell").exec("cmd /c forfiles /P " & ShortName & " /M " & ExtVal & "").stdout.readall, Chr(34), ""), vbCrLf), ".")) + 1
End Sub

[Kenneth Hobs]

Interesting apo, I had not used that command. I would recommend embedding quotes to delimit the drive:\path\filename.ext string rather than using the shortname. I see that you have used that sort of method in the past. http://www.ozgrid.com/forum/showthread.php?t=190073

Of course if all the op wants is the total file count, this will usually suffice.

' =CountFilesInFolder("E:\Research\Final")
Sub Test_()
MsgBox CountFilesInFolder("E:\Research\Final")
End Sub


Function CountFilesInFolder(aFolder As String) As Integer
Application.Volatile (True)
On Error Resume Next
CountFilesInFolder = CreateObject("Scripting.FileSystemObject").GetFolder(aFolder).Files.Count
End Function

[apo]

Hi Kenneth,


I would recommend embedding quotes to delimit the drive:\path\filename.ext string rather than using the shortname.

The reason for the shortname is that I can't seem to get it to work correctly if I use it as you describe above if the Folder selected has a space within it..

Example: "D:\Test" will work.. but "D:\Test This" will yield a zero file count.

Using the shortname guarantees that it works no matter how the Folder name is structured..

If you or anyone can shed some light on the reason why that happens.. please let me know as it adds an extra step in code.

[Kenneth Hobs]

Normally, one just doubles the quotes to embed them. I like to do it this way sometimes to make it clear what I am doing. Sometimes I just use q="""" and concatenate q as needed.


Sub apo()
Dim fldr As FileDialog, SelFold As String, ExtVal As String
Dim ShortName As String

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
If .Show <> -1 Then Exit Sub
SelFold = .SelectedItems(1)
End With
ExtVal = InputBox("File Extension including wildcard and period." & vbLf & "Example: *.xls", _
"Enter File Extension")
'ShortName = CreateObject("Scripting.FileSystemObject").GetFolder(SelFold).ShortName
ShortName = """" & SelFold & """"
MsgBox "File Count: " & UBound(Filter(Split(Replace(CreateObject("wscript.shell").exec _
("cmd /c forfiles /P " & ShortName & " /M " & ExtVal & "").stdout.readall, _
Chr(34), ""), vbCrLf), ".")) + 1
End Sub

[apo]

Good one.. thanks.. I had a feeling it must have been something simple I was missing..

[snb]

This already had been solved in #4 (see the double Quotes)


sub M_snb()
c00="G:\OF\" ' foldername
c01="*.pdf" ' file extension

msgbox ubound(split(createobject("wscript.shell").exec("cmd /c Dir """ & c00 & c01 & """ /b").stdout.readall,vbCrLf))
End Sub

[apo]

Shortname or double quotes aside.. the reason i was giving the Forfiles method a shot was that it seems to overcome DIR's tendency to search on only the first 3 characters..

In my very limited experience.. it seems to me that Forfiles is slower the DIR.. so.. it would be nice if there was way to use DIR and not be limited by a first 3 character search.. is that possible?

[snb]

@apo


DIR's tendency to search on only the first 3 characters..

Did you ever try dir G:\OF\*.xl*

I think you are mistaken. Could you illustrate ?

[apo]

Yeap.. I may have not worded that statement the best.. I will explain..

If I have for example, a Folder with 6 Excel files in it (comprised of 4 x .xls file, 1 x .xlsm file and 1 x .xlsx file) and If i want to find out how many *.xls files there are.

I try using the Dir command like:

dir G:\OF\*.xls (or dir G:\OF\*.xl*)

The result is a count of 6 files.

It seems Dir sees the first 3 characters of the file extension then doesn't care about the rest..

Whereas if i use the Forfiles command.. like i did above.. I can refine my count to include only *.xls files for example..

[Kenneth Hobs]

To finish this thread for the op and for my own edification, I am going to run some time tests for these methods.

APO, the count for that wildcard string is what I would expect. Note that * means that character location and all after whereas ? means just any one single character in that location. So, *.xl* <> *.xls.

[Kenneth Hobs]

I see what you mean APO. Here are my tests and results. There were 3 xls files and 1 xlsx file in the folder. See the attached file for the code.


i = fSNB(c:\myfiles\excel\a\*.xls) i=FileCount: 4 ms: 104.235740977642i = fAPO(c:\myfiles\excel\a, *.xls) i=FileCount: 3 ms: 182.897621173987
i = CountAllFilesInFolder(c:\myfiles\excel\a) i=FileCount: 4 ms: 2.14162364036522
i = CountFilesInFolder(c:\myfiles\excel\a\*.xls) i=FileCount: 4 ms: 7.33165982414988
i = cFileSearch(c:\myfiles\excel\a, *.xls) i=FileCount: 3 ms: 0.541440198012415


i = fSNB(c:\myfiles\excel\a\*.xls) i=FileCount: 4 ms: 97.8317157784561
i = fAPO(c:\myfiles\excel\a, *.xls) i=FileCount: 3 ms: 261.106929776249
i = CountAllFilesInFolder(c:\myfiles\excel\a) i=FileCount: 4 ms: 2.76699529764399
i = CountFilesInFolder(c:\myfiles\excel\a\*.xls) i=FileCount: 4 ms: 7.66628851795694
i = cFileSearch(c:\myfiles\excel\a, *.xls) i=FileCount: 3 ms: 0.601234505594333


i = fSNB(c:\myfiles\excel\a\*.xls) i=FileCount: 4 ms: 140.769514338565
i = fAPO(c:\myfiles\excel\a, *.xls) i=FileCount: 3 ms: 233.654759736598
i = CountAllFilesInFolder(c:\myfiles\excel\a) i=FileCount: 4 ms: 2.8344696080346
i = CountFilesInFolder(c:\myfiles\excel\a\*.xls) i=FileCount: 4 ms: 7.90436860502623
i = cFileSearch(c:\myfiles\excel\a, *.xls) i=FileCount: 3 ms: 0.618240226099283

[apo]

It seems that although Forfiles yields the correct result.. it is quote slow..

I got similar results: (6 x .xlsx/.xlsm files.. 2 x .xls files)


i = fSNB(C:\Chooks\*.xls) i=FileCount: 8 ms: 48.7852608290883
i = fAPO(C:\Chooks, *.xls) i=FileCount: 2 ms: 58.2055941744629
i = CountAllFilesInFolder(C:\Chooks) i=FileCount: 8 ms: 0.207071550331613
i = CountFilesInFolder(C:\Chooks\*.xls) i=FileCount: 8 ms: 1.05299296610938
i = cFileSearch(C:\Chooks, *.xls) i=FileCount: 2 ms: 0.102682458337517


Salutations for the in depth analysis Kenneth.. :)


Note for any other 64 bit users that want to test this: Need to add "PtrSafe" in the Declarations in a few places to make it compile..

[snb]

A curious thing:

remarkable speed improvement with:


Function fSNB(filespec As String) As Integer
With CreateObject("WScript.Shell")
fSNB = UBound(Split(.exec("cmd /c Dir """ & filespec & """ /b").Stdout.Readall, filespec & vbCrLf))
End With
End Function


but even more with:

Function fSNB(filespec As String) As Integer
c01 = Dir(filespec)
c02 = Split(filespec, ".")(1)
Do Until c01 = ""
If Right(c01, Len(c02)) = c02 Then fSNB = fSNB + 1
c01 = Dir
Loop
End Function

[Paul_Hossler]

Merely wondering ....

This has been some very high powered programing, and very interesting and educational

But in the overall scheme of practical matters, wouldn't this fall into the 97%?



Donald Knuth -- Computer Programming as an Art (1974)

Premature optimization is the root of all evil (or at least most of it) in programming.

Programmers waste enormous amounts of time thinking about, or worrying about, the speed of noncritical parts of their programs, and these attempts at efficiency actually have a strong negative impact when debugging and maintenance are considered. We should forget about small efficiencies, say about 97% of the time: premature optimization is the root of all evil. Yet we should not pass up our opportunities in that critical 3%.


I first heard this quote here in VBX (from XLD if I recall correctly) and it so impressed me I had to research the source

If you're going to count files 1 or 10 times, and it takes 1 msec or 100 msec, and do it 1 or 10 times a day, my very personal opinion is that a simpler (OK, dumber) algorithm that is easy for the next person to read and maintain, is better than trying to save a few seconds.

Even the person who wrote it is going to require time to remember what it was doing when they come back to it in six months

Just my philosophical thoughts.

But as I said, I enjoy following the discussion, even when it's above my level