Edit VBA to print Directory including file owner into Excel Spread

M

Melody

Hi,

I posted this in General Questions but I thought I would post it here as
well.

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 flie/folder 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 the informatin into 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
 
A

AndyM

After code line "Cells(R, 3).Value = f1.DateLastModified" within the
ShowFileList sub, enter this line of code:
Cells(R, 7).Value = GetFileOwner(CStr(Folderspec(L)), f1.Name)

Then add the following function:
Function GetFileOwner(fileDir As String, fileName As String) As String
On Error Resume Next
Dim secUtil As Object
Dim secDesc As Object
Set secUtil = CreateObject("ADsSecurityUtility")
Set secDesc = secUtil.GetSecurityDescriptor(fileDir & fileName, 1, 1)
GetFileOwner = secDesc.Owner
End Function

Hope this works for you!
Andy
 
M

Melody

I added the code as you instructed and I'm getting a compile error with the L
highlighted in the below string. Any suggestions?

Cells(R, 7).Value = GetFileOwner(CStr(Folderspec(L)), f1.Name)
 
A

AndyM

What is the message within the compile error?

I tested out the code and it seems to work. I have copied the entire module
that I am using. Try putting this into a new module and see if that works.

'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 ddmmm
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
Cells(R, 7).Value = GetFileOwner(CStr(Folderspec(L)), f1.Name)
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
Function GetFileOwner(fileDir As String, fileName As String) As String
On Error Resume Next
Dim secUtil As Object
Dim secDesc As Object
Set secUtil = CreateObject("ADsSecurityUtility")
Set secDesc = secUtil.GetSecurityDescriptor(fileDir & fileName, 1, 1)
GetFileOwner = secDesc.Owner
End Function
 
M

Melody

Yea! It's working. Thank you, thank you , thank you.

Can I ask for one more thing? I would also like to display the attributes
of the file as well. would you know the code for that as well.
 
A

AndyM

Which file attributes in specific are you looking for? File size, last
modified date, etc.

Andy
 
M

Melody

I would like a column that displays whether the file is read only or not. in
particular.
 
A

AndyM

Try this code. I added the VBA function GetAttr. This returns a number so
the GetFileAttributeName translates that number to a string.

'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 ddmmm
yyyy hh: mm")
Cells(1, 9).Value = "File Attributes"

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
Cells(R, 7).Value = GetFileOwner(CStr(Folderspec(L)), f1.Name)
Cells(R, 9).Value =
GetFileAttributeName(GetAttr(CStr(Folderspec(L)) & f1.Name))
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
Function GetFileOwner(fileDir As String, fileName As String) As String
On Error Resume Next
Dim secUtil As Object
Dim secDesc As Object
Set secUtil = CreateObject("ADsSecurityUtility")
Set secDesc = secUtil.GetSecurityDescriptor(fileDir & fileName, 1, 1)
GetFileOwner = secDesc.Owner
End Function
Function GetFileAttributeName(fileAttribute As Long) As String
If fileAttribute = vbNormal Or fileAttribute = 32 Then
GetFileAttributeName = "Normal"
ElseIf fileAttribute = vbDirectory Then
GetFileAttributeName = "Directory"
ElseIf fileAttribute = vbHidden Or fileAttribute = 34 Then
GetFileAttributeName = "Hidden"
ElseIf fileAttribute = vbReadOnly Or fileAttribute = 33 Then
GetFileAttributeName = "Read-Only"
ElseIf fileAttribute = vbSystem Then
GetFileAttributeName = "System"
ElseIf fileAttribute = vbVolume Then
GetFileAttributeName = "Volume"
Else
GetFileAttributeName = "Unknown"
End If
End Function
 
M

Melody

I can't thank you enough. This is really going to make my job easier. It's
working beautifully.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Print Directory to Excel 13
Range.Find problem 3
type mismatch error in macro in excel 0
Hidden sheet bleeds through 3
Macro to delete row if cells greater than certain value 1
New topic from discussion "Align cells with same value - vba almostworking" in this group 0
Manpower Calendar Distribution, Skipping weekends. 0
Need help to fix vlookup function in macro 1

Top