read directory macro to contain file size

  • Thread starter Thread starter tbmarlie
  • Start date Start date
T

tbmarlie

Hello,

I was given a macro to me that will prompt the user for a file path
and then it returns 1) the file path 2) the name of each file in that
path 3) the date that the file was created.

Eg. Entering c:\escheatables will return
column 1 column 2 column 3
c:\escheatables Actions Items.xls 8/24/2006 9:22
c:\escheatables Queries.doc 7/30/2007 10:40
......etc.

I would like to also have it return the size of the file, but my
visual basic knowledge is not advanced enough to understand how the
current code works. I'm hoping that this may be a fairly easy
addition for someone with more experience with this type of code. The
current code is shown below. Thanks for any help on this.

Global MyFileData As New Collection
Global MyFiles As New Collection
Global MySubDir As New Collection

Sub ReadDirectory(MySearchPath)

Dim MyName


MyName = Dir(MySearchPath, vbDirectory)

Do While MyName <> "" ' Start the loop.
If (GetAttr(MySearchPath & MyName) And vbDirectory) <> vbDirectory
Then
MyFiles.Add Item:=MyName
Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(MySearchPath & MyName)
s = f.DateLastModified
MyFileData.Add Item:=s

End If
MyName = Dir ' Get next entry.
Loop

End Sub

Sub ReadAllDirectory(tmpSubDirectory)

Dim MySearchPath, MyFileSystemObject, MyFolder, MySubFolders,
MyOneSubFolder


MySearchPath = tmpSubDirectory & "\"
Set MyFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set MyFolder = MyFileSystemObject.getfolder(MySearchPath)
Set MySubFolders = MyFolder.subfolders

For Each MyOneSubFolder In MySubFolders
MySubDir.Add Item:=MyOneSubFolder
Call ReadAllDirectory(MyOneSubFolder & "\")
Next MyOneSubFolder

End Sub

Sub MainSearch()

Dim rowcount, tmpMainDirectory

rowcount = 1

tmpMainDirectory = InputBox("Example: S:\Desk Procedures", "Please
enter Root Directory Name")

Call ReadDirectory(tmpMainDirectory & "\")
For y = 1 To MyFiles.Count
Cells(rowcount, 1).Value = tmpMainDirectory
Cells(rowcount, 2).Value = MyFiles.Item(1)
Cells(rowcount, 3).Value = MyFileData.Item(1)
rowcount = rowcount + 1
MyFiles.Remove 1
MyFileData.Remove 1
Next y

Call ReadAllDirectory(tmpMainDirectory)
For x = 1 To MySubDir.Count
Call ReadDirectory(MySubDir.Item(1) & "\")
For y = 1 To MyFiles.Count
Cells(rowcount, 1).Value = MySubDir.Item(1)
Cells(rowcount, 2).Value = MyFiles.Item(1)
Cells(rowcount, 3).Value = MyFileData.Item(1)
rowcount = rowcount + 1
MyFiles.Remove 1
MyFileData.Remove 1
Next y
MySubDir.Remove 1
Next x

MsgBox ("Macro complete!")

End Sub
 
Hi,

For the "Sub ReadDirectory(MySearchPath)" subprocedure:

First, dim another variable to capture the size; for example:

Dim fs, f, s, c

Then, to save the size of the file in KB to the variable c, add:

c = f.size / 1024 & " KB"

Then, add the size to your MyFileData variable:

MyFileData.Add Item:=c

Finally, for the subprocedure "Sub MainSearch()":

Add:

Cells(rowcount, 4).Value = MyFileData.Item(2)

Good Luck ... I haven't tested it ... but I think it'll work.
 
Try the following ... (I'm assuming this is an Excel macro).

Global MyFileData As New Collection
Global MyFiles As New Collection
Global MySubDir As New Collection

Sub ReadDirectory(MySearchPath)

Dim MyName


MyName = Dir(MySearchPath, vbDirectory)

Do While MyName <> "" ' Start the loop.
If (GetAttr(MySearchPath & MyName) And vbDirectory) <> vbDirectory Then
MyFiles.Add Item:=MyName
Dim fs, f, s, c
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(MySearchPath & MyName)
s = f.DateLastModified
c = (f.Size / 1024) & " KB"
MyFileData.Add Item:=s
MyFileData.Add Item:=c

End If
MyName = Dir ' Get next entry.
Loop

End Sub

Sub ReadAllDirectory(tmpSubDirectory)

Dim MySearchPath, MyFileSystemObject, MyFolder, MySubFolders, MyOneSubFolder


MySearchPath = tmpSubDirectory & "\"
Set MyFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set MyFolder = MyFileSystemObject.getfolder(MySearchPath)
Set MySubFolders = MyFolder.subfolders

For Each MyOneSubFolder In MySubFolders
MySubDir.Add Item:=MyOneSubFolder
Call ReadAllDirectory(MyOneSubFolder & "\")
Next MyOneSubFolder

End Sub

Sub MainSearch()

Dim rowcount, tmpMainDirectory

rowcount = 1

tmpMainDirectory = InputBox("Example: S:\Desk Procedures", "Please enter
Root Directory Name")

Call ReadDirectory(tmpMainDirectory & "\")
For y = 1 To MyFiles.Count
Cells(rowcount, 1).Value = tmpMainDirectory
Cells(rowcount, 2).Value = MyFiles.Item(1)
Cells(rowcount, 3).Value = MyFileData.Item(1)
Cells(rowcount, 4).Value = MyFileData.Item(2)
rowcount = rowcount + 1
MyFiles.Remove 1
MyFileData.Remove 1
MyFileData.Remove 2
Next y

Call ReadAllDirectory(tmpMainDirectory)
For x = 1 To MySubDir.Count
Call ReadDirectory(MySubDir.Item(1) & "\")
For y = 1 To MyFiles.Count
Cells(rowcount, 1).Value = MySubDir.Item(1)
Cells(rowcount, 2).Value = MyFiles.Item(1)
Cells(rowcount, 3).Value = MyFileData.Item(1)
rowcount = rowcount + 1
MyFiles.Remove 1
MyFileData.Remove 1
Next y
MySubDir.Remove 1
Next x

MsgBox ("Macro complete!")

End Sub
 
Sorry about that ... when I tested it ... it didn't work ... embarassing!

This one however appears to work. Mea Culpa.

**************************************************

Option Explicit
Global MyFileData As New Collection
Global MyFiles As New Collection
Global MySubDir As New Collection

Sub ReadDirectory(MySearchPath)

Dim MyName


MyName = Dir(MySearchPath, vbDirectory)

Do While MyName <> "" ' Start the loop.
If (GetAttr(MySearchPath & MyName) And vbDirectory) <> vbDirectory Then
MyFiles.Add Item:=MyName
Dim fs, f, s, c
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(MySearchPath & MyName)
s = f.DateLastModified
c = WorksheetFunction.RoundUp((f.Size / 1024), 0) & " KB"
MyFileData.Add Item:=s
MyFileData.Add Item:=c

End If
MyName = Dir ' Get next entry.
Loop

End Sub

Sub ReadAllDirectory(tmpSubDirectory)

Dim MySearchPath, MyFileSystemObject, MyFolder, MySubFolders, MyOneSubFolder


MySearchPath = tmpSubDirectory & "\"
Set MyFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set MyFolder = MyFileSystemObject.getfolder(MySearchPath)
Set MySubFolders = MyFolder.subfolders

For Each MyOneSubFolder In MySubFolders
MySubDir.Add Item:=MyOneSubFolder
Call ReadAllDirectory(MyOneSubFolder & "\")
Next MyOneSubFolder

End Sub

Sub MainSearch()

Dim rowcount As Integer, tmpMainDirectory As String, y As Integer, x As
Integer

rowcount = 1

tmpMainDirectory = InputBox("Example: S:\Desk Procedures", "Please enter
Root Directory Name")

Call ReadDirectory(tmpMainDirectory & "\")
For y = 1 To MyFiles.Count
Cells(rowcount, 1).Value = tmpMainDirectory
Cells(rowcount, 2).Value = MyFiles.Item(1)
Cells(rowcount, 3).Value = MyFileData.Item(1)
Cells(rowcount, 4).Value = MyFileData.Item(2)
rowcount = rowcount + 1
MyFiles.Remove 1
MyFileData.Remove 1
MyFileData.Remove 1
Next y

Call ReadAllDirectory(tmpMainDirectory)
For x = 1 To MySubDir.Count
Call ReadDirectory(MySubDir.Item(1) & "\")
For y = 1 To MyFiles.Count
Cells(rowcount, 1).Value = MySubDir.Item(1)
Cells(rowcount, 2).Value = MyFiles.Item(1)
Cells(rowcount, 3).Value = MyFileData.Item(1)
rowcount = rowcount + 1
MyFiles.Remove 1
MyFileData.Remove 1
MyFileData.Remove 1
Next y
MySubDir.Remove 1
Next x

MsgBox ("Macro complete!")

End Sub
 
Back
Top