Ettornio
11-18-2009, 10:58 AM
Hi.
I've tried searching for this answer to my problem for the past 4 hours to no avail. I just can't wrap my head around it. Here's the problem...
The boss was super impressed with what I did to the "Directory Listing.xls" file (can't post links -- google filename) and how I organized it for what we needed. But now they want an extra cell to show who is the owner of each individual file! I'm not a wizard, so I am in dire need of help. Here's what I've got so far:
Note: This is different from what is in the original.
'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 = "**" Then IsCD = True
If Cells(2, 2).Value = "**" 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 = 100
Cells.ClearContents
Cells(1, 1).Value = "Path"
Cells(1, 2).Value = "File Name"
Cells(1, 3).Value = "Date Modified (24 hour clock)"
Cells(1, 4).Value = "Last Accessed (24 hour clock)"
Cells(1, 5).Value = "File Size in Bytes"
Cells(1, 6).Value = "Total Directory Size in Bytes"
Cells(1, 7).Value = "Date Created (24 Hour Clock)"
Cells(1, 8).Value = "Last Compiled On:"
Cells(1, 9).Value = Application.WorksheetFunction.Text(Now(), "ddd dd mmm yyyy hh:mm")
Cells(1, 10).Value = "Testing"
Cells(2, 2).Select
ActiveWindow.FreezePanes = False
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 **. If this is the case please enter ** 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
On Error Resume Next
Cells(R, 3).Value = f1.DateLastModified
Select Case Err 'There is no Date recorded, found once on a pdf on a **
Case 1004
Cells(R, 3).Value = "Not Known"
End Select
On Error GoTo 0
If IsCD Then
Else
MaybeCD = True
Cells(R, 4).Value = f1.DateLastAccessed
MaybeCD = False
End If
Cells(R, 5).Value = f1.Size
Cells(R, 7).Value = f1.DateCreated
Cells(R, 10).Value = ownerID
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, 8), Cells(R, 8 + N)).Interior.ColorIndex = 3
Else
N = 99 * Round(Cells(R, 5).Value / MaxFile, 2)
Range(Cells(R, 8), Cells(R, 8 + N)).Interior.ColorIndex = 4
End If
Cells(R + 1, 5).Select
Next R
R = R + 1
Cells(R, 2).Value = "Total Size in Bytes"
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 of Files"
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
Sub NWIntScanExtendedInfo()
End Sub
Sub OnlyLarge()
'Short Cut = Ctrl + z
Application.ScreenUpdating = False
If ActiveSheet.Name = "Data" Then
On Error GoTo Finish
Columns("DC:DC").ClearContents
Title = "Filter"
Prompt = "Enter the Threshold Path Length"
MaxP = InputBox(Prompt, Title, 255) + 0
Prompt = "Enter the Threshold File Length"
MaxF = InputBox(Prompt, Title, 255) + 0
Prompt = "Enter the Threshold Path + File Length"
MaxPF = InputBox(Prompt, Title, 255) + 0
ActiveSheet.AutoFilterMode = False
Rl = Cells(65536, 1).End(xlUp).Row
For R = 2 To Rl
Disp = False
If Len(Cells(R, 1).Value) > MaxP Then Disp = True
If Len(Cells(R, 2).Value) > MaxF Then Disp = True
If Len(Cells(R, 1).Value) + Len(Cells(R, 2).Value) > MaxPF Then Disp = True
If Disp Then Cells(R, 107).Value = 1
Next R
Range(Cells(1, 1), Cells(Rl, 107)).Select
Selection.AutoFilter Field:=107, Criteria1:="1"
Range("A1").Select
Range(Selection, Cells(Cells(65536, 1).End(xlUp).Row, 2)).Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = "Large"
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").AutoFit
ActiveWindow.Zoom = 75
Sheets("Data").Select
Selection.AutoFilter Field:=107
Columns("DC:DC").ClearContents
Range("B2").Select
Sheets("Large").Select
Range("B2").Select
ActiveWindow.FreezePanes = True
Application.CutCopyMode = False
Cells(1, 3).Value = "Path > " & MaxP & _
" + File > " & MaxF & " + Path\File > " & MaxPF
End If
Finish:
End Sub
Note that Cells(1, 10) say "Testing". This is the column where I'm trying to add each individual file's novell netware info owner. I've found some resources about how to do this, but I can't think of how the hell to apply them. BTW I do have permission to view who owns each file by right-clicking on it -> Properties -> NetWare Info Tab
[see next post]
I've tried searching for this answer to my problem for the past 4 hours to no avail. I just can't wrap my head around it. Here's the problem...
The boss was super impressed with what I did to the "Directory Listing.xls" file (can't post links -- google filename) and how I organized it for what we needed. But now they want an extra cell to show who is the owner of each individual file! I'm not a wizard, so I am in dire need of help. Here's what I've got so far:
Note: This is different from what is in the original.
'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 = "**" Then IsCD = True
If Cells(2, 2).Value = "**" 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 = 100
Cells.ClearContents
Cells(1, 1).Value = "Path"
Cells(1, 2).Value = "File Name"
Cells(1, 3).Value = "Date Modified (24 hour clock)"
Cells(1, 4).Value = "Last Accessed (24 hour clock)"
Cells(1, 5).Value = "File Size in Bytes"
Cells(1, 6).Value = "Total Directory Size in Bytes"
Cells(1, 7).Value = "Date Created (24 Hour Clock)"
Cells(1, 8).Value = "Last Compiled On:"
Cells(1, 9).Value = Application.WorksheetFunction.Text(Now(), "ddd dd mmm yyyy hh:mm")
Cells(1, 10).Value = "Testing"
Cells(2, 2).Select
ActiveWindow.FreezePanes = False
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 **. If this is the case please enter ** 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
On Error Resume Next
Cells(R, 3).Value = f1.DateLastModified
Select Case Err 'There is no Date recorded, found once on a pdf on a **
Case 1004
Cells(R, 3).Value = "Not Known"
End Select
On Error GoTo 0
If IsCD Then
Else
MaybeCD = True
Cells(R, 4).Value = f1.DateLastAccessed
MaybeCD = False
End If
Cells(R, 5).Value = f1.Size
Cells(R, 7).Value = f1.DateCreated
Cells(R, 10).Value = ownerID
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, 8), Cells(R, 8 + N)).Interior.ColorIndex = 3
Else
N = 99 * Round(Cells(R, 5).Value / MaxFile, 2)
Range(Cells(R, 8), Cells(R, 8 + N)).Interior.ColorIndex = 4
End If
Cells(R + 1, 5).Select
Next R
R = R + 1
Cells(R, 2).Value = "Total Size in Bytes"
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 of Files"
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
Sub NWIntScanExtendedInfo()
End Sub
Sub OnlyLarge()
'Short Cut = Ctrl + z
Application.ScreenUpdating = False
If ActiveSheet.Name = "Data" Then
On Error GoTo Finish
Columns("DC:DC").ClearContents
Title = "Filter"
Prompt = "Enter the Threshold Path Length"
MaxP = InputBox(Prompt, Title, 255) + 0
Prompt = "Enter the Threshold File Length"
MaxF = InputBox(Prompt, Title, 255) + 0
Prompt = "Enter the Threshold Path + File Length"
MaxPF = InputBox(Prompt, Title, 255) + 0
ActiveSheet.AutoFilterMode = False
Rl = Cells(65536, 1).End(xlUp).Row
For R = 2 To Rl
Disp = False
If Len(Cells(R, 1).Value) > MaxP Then Disp = True
If Len(Cells(R, 2).Value) > MaxF Then Disp = True
If Len(Cells(R, 1).Value) + Len(Cells(R, 2).Value) > MaxPF Then Disp = True
If Disp Then Cells(R, 107).Value = 1
Next R
Range(Cells(1, 1), Cells(Rl, 107)).Select
Selection.AutoFilter Field:=107, Criteria1:="1"
Range("A1").Select
Range(Selection, Cells(Cells(65536, 1).End(xlUp).Row, 2)).Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = "Large"
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").AutoFit
ActiveWindow.Zoom = 75
Sheets("Data").Select
Selection.AutoFilter Field:=107
Columns("DC:DC").ClearContents
Range("B2").Select
Sheets("Large").Select
Range("B2").Select
ActiveWindow.FreezePanes = True
Application.CutCopyMode = False
Cells(1, 3).Value = "Path > " & MaxP & _
" + File > " & MaxF & " + Path\File > " & MaxPF
End If
Finish:
End Sub
Note that Cells(1, 10) say "Testing". This is the column where I'm trying to add each individual file's novell netware info owner. I've found some resources about how to do this, but I can't think of how the hell to apply them. BTW I do have permission to view who owns each file by right-clicking on it -> Properties -> NetWare Info Tab
[see next post]