Thanks for the link. I can't run that program. I'm using my PC at work and
there are restrictions to installing programs. That's why I wanted to use
the VB programming.

"Kevin B" wrote:

See if this free add-in from Chip Pearson's website doesn't do the trick.

It installs as an XLA add-in and is accessed via the TOOLS menu in Excel.

http://www.cpearson.com/Excel/FolderTree.aspx
--
Kevin Backmann


"Melody" wrote:

Hi,

I was able to find an Excel Spreadsheet with a macro to print the directory
structure. The script is below. I want to add the Owner to the printout but
I'm not very proficient in VB. I found where to add the column heading but
not the actual programming to pull it in the spreadsheet. Can anyone help
add that parameter to this script?

Thanks.

'Concept by Michael Hayes, core code from MS example
Global L
Global R
Global C
Global LastR
Global IsCD
Global MaybeCD
Global Folderspec(100)
Sub Shell()
Application.ScreenUpdating = False
Application.ActiveSheet.UsedRange
IsCD = False
MaybeCD = False
L = 1
R = 2
LastR = R
Sheets("Data").Select
On Error GoTo ErrDir
If Cells(2, 2).Value = "CD" Then IsCD = True
If Cells(2, 2).Value = "cd" Then IsCD = True
Cells.Interior.ColorIndex = 2
Cells.Font.ColorIndex = 1
Folderspec(L) = Cells(R, 1).Value
If Right(Folderspec(L), 1) = "\" Then
Else
GoTo ErrDir
End If
ActiveWindow.Zoom = 75
Cells.ClearContents
Cells(1, 1).Value = "Path"
Cells(1, 2).Value = "File"
Cells(1, 3).Value = "Last Saved"
Cells(1, 4).Value = "Last Accessed"
Cells(1, 5).Value = "File (B)"
Cells(1, 6).Value = "Directory (B)"
Cells(1, 7).Value = "Owner"
Cells(1, 8).Value = Application.WorksheetFunction.Text(Now(), "ddd dd
mmm yyyy hh:mm")
Cells(2, 2).Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 75
Call ShowFileList
Application.ScreenUpdating = True
Set W = Application.WorksheetFunction
Cells(LastR, 6).Value = W.Sum(Range(Cells(LastR, 5), Cells(R, 5)))
Cells.AutoFilter Field:=6, Criteria1:="<"
Sheets("Summary").Select
Cells.ClearContents
Cells.ClearFormats
Sheets("Data").Select
Range(Cells(1, 1), Cells(R, 6)).Copy
Sheets("Summary").Select
Cells(1, 1).Select
ActiveSheet.Paste
Cells.EntireColumn.AutoFit
Columns("B:E").Select
Selection.Delete
Cells(2, 2).Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 75
Call Sort
Sheets("Data").Select
Cells.AutoFilter
Call Display
Exit Sub
ErrDir:
Select Case Err
Case 1004
Prompt = "Tried to write past end of Sheet"
Case Else
Sheets("Data").Select
D = Cells(2, 1).Value
If MaybeCD Then
Prompt = "The Source may be on a CD. If this is the case
please enter CD in cell B2"
Else
Prompt = "The current Root Path is " & D & vbCrLf & _
" If this is not correct, then enter a new path
in Cell A2 in 'Data'" & vbCrLf & _
"Note that the path must end with \ "
End If
End Select
MsgBox (Prompt)
End Sub
Sub ShowFileList()
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Folderspec(L))
Set fc = f.Files
Cells(R, 1).Value = Folderspec(L)
Application.ScreenUpdating = True
Cells(R, 1).Select
Application.ScreenUpdating = False
Set W = Application.WorksheetFunction
Cells(LastR, 6).Value = W.Sum(Range(Cells(LastR, 5), Cells(R, 5)))
LastR = R
On Error Resume Next
For Each f1 In fc
Select Case Err
Case 70 'Don't have access
With Cells(R, 2)
.Value = "Access to this directory is denied"
.Font.ColorIndex = 3
End With
On Error GoTo 0
Exit Sub
Case 0 'Normal Access
On Error GoTo 0
R = R + 1
With Cells(R, 1)
.Value = Folderspec(L)
.Font.ColorIndex = 15
End With
Cells(R, 2).Value = f1.Name
Cells(R, 3).Value = f1.DateLastModified
If IsCD Then
Else
MaybeCD = True
Cells(R, 4).Value = f1.DateLastAccessed
MaybeCD = False
End If
Cells(R, 5).Value = f1.Size
Case Else 'Not sure what this error would be
Exit Sub
End Select
On Error Resume Next
Next
On Error GoTo 0
Call ShowFolderList
End Sub
Sub ShowFolderList()
Dim fs, f, f1, s, sf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Folderspec(L))
Set sf = f.SubFolders
a = f.SubFolders.Count
For Each f1 In sf
L = L + 1
Folderspec(L) = Folderspec(L - 1) & f1.Name & "\"
R = R + 1
Call ShowFileList
L = L - 1
Next
End Sub
Sub Display()
Set W = Application.WorksheetFunction
Cells.Interior.ColorIndex = 2
Range(Cells(1, 1), Cells(1, 106)).Interior.ColorIndex = 34
MaxFile = W.Max(Range(Cells(2, 5), Cells(65536, 5)))
MaxDirectory = W.Max(Range(Cells(2, 6), Cells(65536, 6)))
Cells(65536, 5).Select
Selection.End(xlUp).Select
EOD = ActiveCell.Row
For R = 2 To EOD
If Cells(R, 5).Value = "" Then
N = 99 * Round(Cells(R, 6).Value / MaxDirectory, 2)
Range(Cells(R, 7), Cells(R, 7 + N)).Interior.ColorIndex = 3
Else
N = 99 * Round(Cells(R, 5).Value / MaxFile, 2)
Range(Cells(R, 7), Cells(R, 7 + N)).Interior.ColorIndex = 4
End If
Cells(R + 1, 5).Select
Next R
R = R + 1
Cells(R, 2).Value = "Total Size"
Cells(R, 5).Formula = "=Subtotal(9,E2:E" & R - 1 & ")"
Cells(R, 6).Formula = "=Subtotal(9,F2:F" & R - 1 & ")"
R = R + 2
Cells(R, 2).Value = "Total Number"
Cells(R, 5).Formula = "=Subtotal(2,E2:E" & R - 3 & ")"
Cells(R, 6).Formula = "=Subtotal(2,F2:F" & R - 3 & ")"
Range(Cells(1, 1), Cells(EOD, 6)).Select
Selection.AutoFilter
Cells(1, 1).Select
End Sub
Sub Sort()
Range("A2").Select
Selection.CurrentRegion.Select
Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("B2").Select
End Sub