Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Edit VBA to print Directory including file owner into Excel Spread
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Edit VBA to print Directory including file owner into Excel Spread
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 "Melody" wrote: 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Edit VBA to print Directory including file owner into Excel Sp
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) "AndyM" wrote: 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 "Melody" wrote: 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Edit VBA to print Directory including file owner into Excel Sp
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 "Melody" wrote: 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) "AndyM" wrote: 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 "Melody" wrote: 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Edit VBA to print Directory including file owner into Excel Sp
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 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 "Melody" wrote: 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) "AndyM" wrote: 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 "Melody" wrote: 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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Edit VBA to print Directory including file owner into Excel Sp
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 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 "Melody" wrote: 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) "AndyM" wrote: 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 "Melody" wrote: 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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Edit VBA to print Directory including file owner into Excel Sp
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 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 "Melody" wrote: 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) "AndyM" wrote: 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 "Melody" wrote: 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 |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Edit VBA to print Directory including file owner into Excel Sp
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 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 "Melody" wrote: 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) "AndyM" wrote: 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 "Melody" wrote: 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") |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Edit VBA to print Directory including file owner into Excel Sp
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
file owner properties | Excel Programming | |||
how can I check the current owner of the file stored in a common D | Excel Discussion (Misc queries) | |||
I need to print lists including a barcode in Excel. | Excel Discussion (Misc queries) | |||
edit Excel spread sheet | New Users to Excel | |||
owner/author of a file | Excel Programming |