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

"AndyM" wrote:

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



"Melody" wrote:

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

"AndyM" wrote:

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

Andy

"Melody" wrote:

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.



"AndyM" wrote:

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