Count of all files on C:\
RB Smissaert
What is the quickest way to get the count of all files of any sort on the C
drive?
Found some code on Fred Cumming's website
http://www.netspace.net.au/~fcfhsp/xlhome.htm
that does it, but this is rather slow (I get about 80.000 files). Is there
any quicker way, perhaps using API?
This is the best I got for now, adapted from Fred Cumming's FileLister:
Sub CountFiles()
Dim Directories() As String
Dim CurrentDirectory As String
Dim DirCounter As Long
Dim DirValue As String
StartPoint = "C:\"
ReDim Directories(2)
Directories(1) = StartPoint
Directories(2) = ""
' initialise Directory counter
DirCounter = 1
FileCount = 0
On Error Resume Next
' Now loop through the directories() array.
' For each entry test whether it's a file or a directory.
' If it's a file then add it to the filelist() array.
' If it's a directory then add it to the directories() array.
' Keep going until there are no more entries in the directories
array()!!
Do While Directories(DirCounter) <> ""
CurrentDirectory = Directories(DirCounter)
' use the DIR() function to get the first entry for the current
directory
DirValue = Dir(CurrentDirectory, vbDirectory + vbHidden + vbSystem)
Do While DirValue <> ""
If InStr("..", DirValue) = 0 Then
' Use the GetAttr() function to check whether the entry is a
directory.
' it's a directory entry so check to see if it's "." or ".."
' these are returned by the DIR() function but should be
ignored
dirok = GetAttr(CurrentDirectory & DirValue) And vbDirectory
If dirok Then
' Add one more line to the Directories() array and
' paste the text into the array.
ReDim Preserve Directories(UBound(Directories) + 1)
Directories(UBound(Directories) - 1) = CurrentDirectory
& DirValue & "\"
Else
FileCount = FileCount + 1
If Int(FileCount / 10) - FileCount / 10 = 0 Then
Application.StatusBar = _
CurrentDirectory & " FolderCount: " &
DirCounter & _
" FileCount: " & FileCount
End If
End If
End If
' get the next value fron the DIR() function
DirValue = Dir()
Loop
DirCounter = DirCounter + 1
Loop
Application.StatusBar = False
MsgBox FileCount
End Sub
Thanks for any advice.
RBS
Dave Peterson
(from the help on FileSearch (.subfolders example))
Set fs = Application.FileSearch
With fs
.LookIn = "C:\"
.SearchSubFolders = True
.Filename = "*.*"
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For i = 1 To .FoundFiles.Count
MsgBox .FoundFiles(i)
Next i
Else
MsgBox "There were no files found."
End If
End With
===
Maybe someone more familiar with the FileSystemObject can provide a faster
method using that.
--
Dave Peterson
ec3...@msn.com
Dave Peterson
HD and number of files.
(I had to ctrl-break out, but I get bored easily!)
Save your work beforehand, just in case.
--
Dave Peterson
ec3...@msn.com
Jake Marx
Here's a way to do it using recursion and the FileSystemObject. To use
this, you must first set a reference to the Microsoft Scripting Runtime
library via Tools | References.
This routine gives a slightly different number than Fred's or Dave's code
(at least on my machine). Not sure which is correct. Nevertheless, this
FSO-based routine is *much* faster on my machine than either of the others,
so you may want to give it a try. To use it, just pass a string into the
GetNumFiles subroutine that represents the folder you wish to start the
count in. In your case, you would want to use this line of code:
GetNumFiles "c:\"
This was thrown together and hasn't been tested much, but it should work OK.
Regards,
Jake Marx
'/-------------BEGIN CODE SAMPLE------------
Private mfso As Scripting.FileSystemObject
Private mlRow As Long
Private mlTotals() As Long
Private Function lNumFilesInFolder(rfldTarget As _
Scripting.Folder, Optional rbInit As Boolean = False) _
As Long
Dim fld As Scripting.Folder
On Error GoTo ErrHandler
If rbInit Then
mlRow = 0
ReDim mlTotals(0 To mlRow)
mlTotals(mlRow) = rfldTarget.Files.Count
End If
For Each fld In rfldTarget.SubFolders
mlRow = mlRow + 1
ReDim Preserve mlTotals(0 To mlRow)
mlTotals(mlRow) = lNumFilesInFolder(fld)
Next fld
lNumFilesInFolder = rfldTarget.Files.Count
ExitRoutine:
Exit Function
ErrHandler:
Resume ExitRoutine
End Function
Public Sub GetNumFiles(rlFolder As String)
Dim lRow As Long
Dim lTotNumFiles As Long
Set mfso = New Scripting.FileSystemObject
lNumFilesInFolder mfso.GetFolder(rlFolder), True
For lRow = LBound(mlTotals) To UBound(mlTotals)
lTotNumFiles = lTotNumFiles + mlTotals(lRow)
Next lRow
MsgBox "There are " & Format$(lTotNumFiles, "0,000") & _
" files in '" & rlFolder & "' and its subfolders.", _
vbInformation, "File Count Results"
Set mfso = Nothing
End Sub
'/-------------END CODE SAMPLE------------
"RB Smissaert" <bartsm...@blueyonder.co.uk> wrote in message
news:0jqw7.32318$II.21...@news1.cableinet.net...
RB Smissaert
Thanks, that is very fast indeed.
I just have one question.
What I would like to do is set the reference to the Microsoft Scripting
Runtime library in VBA and then remove it after running the filecounter. How
can I do this (setting the reference) when the module contains code that
already needs this library? I have the code to set and remove the reference:
Sub ActivateScriptingRuntime()
Dim R
For Each R In ActiveWorkbook.VBProject.References
If R.GUID = "{420B2830-E718-11CF-893D-00A0C9054228}" Then
Exit Sub
End If
Next
On Error GoTo NotFound
ActiveWorkbook.VBProject.References.AddFromGuid _
GUID:="{420B2830-E718-11CF-893D-00A0C9054228}", _
Major:=1, Minor:=0
Exit Sub
NotFound:
MsgBox "CAN'T RUN THIS CODE" & vbCrLf & vbCrLf & _
"ScriptingRuntime IS NOT ON THIS COMPUTER"
End Sub
Sub RemoveScriptingRuntime()
ActiveWorkbook.VBProject.References.Remove _
ActiveWorkbook.VBProject.References("Scripting")
Jake Marx
Well, you may just want to use Late Binding to do this instead of setting a
reference. I've pasted the necessary code below for your reference. Notice
that it checks for a 429 error, which would occur if the user doesn't have
the MS Scripting Runtime library on their machine (should be rare
occurrence).
Regards,
Jake Marx
'/-------------BEGIN CODE SAMPLE------------
Private mfso As Object
Private mlRow As Long
Private mlTotals() As Long
Private Function lNumFilesInFolder(rfldTarget As _
Object, Optional rbInit As Boolean = False) _
As Long
Dim fld As Object
On Error GoTo ErrHandler
If rbInit Then
mlRow = 0
ReDim mlTotals(0 To mlRow)
mlTotals(mlRow) = rfldTarget.Files.Count
End If
For Each fld In rfldTarget.SubFolders
mlRow = mlRow + 1
ReDim Preserve mlTotals(0 To mlRow)
mlTotals(mlRow) = lNumFilesInFolder(fld)
Next fld
lNumFilesInFolder = rfldTarget.Files.Count
ExitRoutine:
Exit Function
ErrHandler:
Resume ExitRoutine
End Function
Public Sub GetNumFiles(rlFolder As String)
Dim lRow As Long
Dim lTotNumFiles As Long
On Error GoTo ErrHandler
Set mfso = CreateObject("Scripting.FileSystemObject")
lNumFilesInFolder mfso.GetFolder(rlFolder), True
For lRow = LBound(mlTotals) To UBound(mlTotals)
lTotNumFiles = lTotNumFiles + mlTotals(lRow)
Next lRow
MsgBox "There are " & Format$(lTotNumFiles, "0,000") & _
" files in '" & rlFolder & "' and its subfolders.", _
vbInformation, "File Count Results"
ExitRoutine:
Set mfso = Nothing
Exit Sub
ErrHandler:
If Err.Number = 429 Then
MsgBox "You do not have the Microsoft Scripting " _
& "Runtime library. Unable to continue.", _
vbCritical, "ERROR"
Else
MsgBox "Unexpected error. Unable to continue.", _
vbCritical, "ERROR"
End If
Resume ExitRoutine
End Sub
'/-------------END CODE SAMPLE------------
"RB Smissaert" <bartsm...@blueyonder.co.uk> wrote in message
news:HPCw7.38405$II.25...@news1.cableinet.net...
RB Smissaert
Thanks for the code. Nice and quick indeed. Will have to study it a bit as I
never used the FileSystem object.
RBS