Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
Print Directory to Excel
Hi,
I was able to find an Excel Spreadsheet with a macro to print the directory structure. The script is below. I want to add the Owner to the printout but I'm not very proficient in VB. I found where to add the column heading but not the actual programming to pull it in the spreadsheet. Can anyone help add that parameter to this script? Thanks. 'Concept by Michael Hayes, core code from MS example Global L Global R Global C Global LastR Global IsCD Global MaybeCD Global Folderspec(100) Sub Shell() Application.ScreenUpdating = False Application.ActiveSheet.UsedRange IsCD = False MaybeCD = False L = 1 R = 2 LastR = R Sheets("Data").Select On Error GoTo ErrDir If Cells(2, 2).Value = "CD" Then IsCD = True If Cells(2, 2).Value = "cd" Then IsCD = True Cells.Interior.ColorIndex = 2 Cells.Font.ColorIndex = 1 Folderspec(L) = Cells(R, 1).Value If Right(Folderspec(L), 1) = "\" Then Else GoTo ErrDir End If ActiveWindow.Zoom = 75 Cells.ClearContents Cells(1, 1).Value = "Path" Cells(1, 2).Value = "File" Cells(1, 3).Value = "Last Saved" Cells(1, 4).Value = "Last Accessed" Cells(1, 5).Value = "File (B)" Cells(1, 6).Value = "Directory (B)" Cells(1, 7).Value = "Owner" Cells(1, 8).Value = Application.WorksheetFunction.Text(Now(), "ddd dd mmm yyyy hh:mm") Cells(2, 2).Select ActiveWindow.FreezePanes = True ActiveWindow.Zoom = 75 Call ShowFileList Application.ScreenUpdating = True Set W = Application.WorksheetFunction Cells(LastR, 6).Value = W.Sum(Range(Cells(LastR, 5), Cells(R, 5))) Cells.AutoFilter Field:=6, Criteria1:="<" Sheets("Summary").Select Cells.ClearContents Cells.ClearFormats Sheets("Data").Select Range(Cells(1, 1), Cells(R, 6)).Copy Sheets("Summary").Select Cells(1, 1).Select ActiveSheet.Paste Cells.EntireColumn.AutoFit Columns("B:E").Select Selection.Delete Cells(2, 2).Select ActiveWindow.FreezePanes = True ActiveWindow.Zoom = 75 Call Sort Sheets("Data").Select Cells.AutoFilter Call Display Exit Sub ErrDir: Select Case Err Case 1004 Prompt = "Tried to write past end of Sheet" Case Else Sheets("Data").Select D = Cells(2, 1).Value If MaybeCD Then Prompt = "The Source may be on a CD. If this is the case please enter CD in cell B2" Else Prompt = "The current Root Path is " & D & vbCrLf & _ " If this is not correct, then enter a new path in Cell A2 in 'Data'" & vbCrLf & _ "Note that the path must end with \ " End If End Select MsgBox (Prompt) End Sub Sub ShowFileList() Dim fs, f, f1, fc, s Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(Folderspec(L)) Set fc = f.Files Cells(R, 1).Value = Folderspec(L) Application.ScreenUpdating = True Cells(R, 1).Select Application.ScreenUpdating = False Set W = Application.WorksheetFunction Cells(LastR, 6).Value = W.Sum(Range(Cells(LastR, 5), Cells(R, 5))) LastR = R On Error Resume Next For Each f1 In fc Select Case Err Case 70 'Don't have access With Cells(R, 2) .Value = "Access to this directory is denied" .Font.ColorIndex = 3 End With On Error GoTo 0 Exit Sub Case 0 'Normal Access On Error GoTo 0 R = R + 1 With Cells(R, 1) .Value = Folderspec(L) .Font.ColorIndex = 15 End With Cells(R, 2).Value = f1.Name Cells(R, 3).Value = f1.DateLastModified If IsCD Then Else MaybeCD = True Cells(R, 4).Value = f1.DateLastAccessed MaybeCD = False End If Cells(R, 5).Value = f1.Size Case Else 'Not sure what this error would be Exit Sub End Select On Error Resume Next Next On Error GoTo 0 Call ShowFolderList End Sub Sub ShowFolderList() Dim fs, f, f1, s, sf Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(Folderspec(L)) Set sf = f.SubFolders a = f.SubFolders.Count For Each f1 In sf L = L + 1 Folderspec(L) = Folderspec(L - 1) & f1.Name & "\" R = R + 1 Call ShowFileList L = L - 1 Next End Sub Sub Display() Set W = Application.WorksheetFunction Cells.Interior.ColorIndex = 2 Range(Cells(1, 1), Cells(1, 106)).Interior.ColorIndex = 34 MaxFile = W.Max(Range(Cells(2, 5), Cells(65536, 5))) MaxDirectory = W.Max(Range(Cells(2, 6), Cells(65536, 6))) Cells(65536, 5).Select Selection.End(xlUp).Select EOD = ActiveCell.Row For R = 2 To EOD If Cells(R, 5).Value = "" Then N = 99 * Round(Cells(R, 6).Value / MaxDirectory, 2) Range(Cells(R, 7), Cells(R, 7 + N)).Interior.ColorIndex = 3 Else N = 99 * Round(Cells(R, 5).Value / MaxFile, 2) Range(Cells(R, 7), Cells(R, 7 + N)).Interior.ColorIndex = 4 End If Cells(R + 1, 5).Select Next R R = R + 1 Cells(R, 2).Value = "Total Size" Cells(R, 5).Formula = "=Subtotal(9,E2:E" & R - 1 & ")" Cells(R, 6).Formula = "=Subtotal(9,F2:F" & R - 1 & ")" R = R + 2 Cells(R, 2).Value = "Total Number" Cells(R, 5).Formula = "=Subtotal(2,E2:E" & R - 3 & ")" Cells(R, 6).Formula = "=Subtotal(2,F2:F" & R - 3 & ")" Range(Cells(1, 1), Cells(EOD, 6)).Select Selection.AutoFilter Cells(1, 1).Select End Sub Sub Sort() Range("A2").Select Selection.CurrentRegion.Select Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Range("B2").Select End Sub |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Searching Excel Directory | Excel Discussion (Misc queries) | |||
Excel and Active Directory | Excel Discussion (Misc queries) | |||
list of all subdirectories in a given directory in excel | Excel Worksheet Functions | |||
list directory in EXCEL | Excel Discussion (Misc queries) | |||
Excel active directory | Setting up and Configuration of Excel |