Sub ImportFolderInfo()
If ActiveSheet Is Nothing Then
MsgBox "There is no Active Workbook !!!"
Exit Sub
End If
Dim DirPath, FileSaveName
FileSaveName = Application.GetSaveAsFilename( _
"Select This Folder", _
Title:="Open The Folder And Click The [Save] Button")
If FileSaveName <> False Then
DirPath = Left(FileSaveName, Len(FileSaveName) - 19)
shPATH = DirPath
''shPATH = "C:\"
PathSep = 0
For i = (Len(DirPath) - 1) To 1 Step -1
If Mid(DirPath, i, 1) = Application.PathSeparator Then
PathSep = 1
DirName = Mid(DirPath, i + 1, Len(DirPath))
'ShName = "DIRECTORY_INFO" + Mid(DirName, 1, Len(DirName) - 1)
ShName = "DIRECTORY_INFO"
Exit For
End If
Next
If PathSep = 0 Then
DirName = Left(DirPath, Len(DirPath) - 1)
ShName = "ROOT " + Mid(DirName, 1, Len(DirName) - 1)
End If
Dim fs, f, ffile, fc
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(DirPath)
Set fc = f.SubFolders
Dim No
PAVLA = ""
On Error GoTo SheetNameError
Set NewSheet = Worksheets.Add
NextName:
NewSheet.Name = ShName & PAVLA & No
No = 1
Cells(1, 1) = "A/A"
Cells(1, 2) = "DIRECTORY"
Cells(1, 3) = "SIZE"
Cells(1, 4) = "EXT"
Cells(1, 5) = "ATTRIBUTES"
Cells(1, 6) = "FILES"
Cells(1, 7) = "sDIRS"
Cells(1, 8) = "CREATED"
Cells(1, 9) = "ACCESSED"
Cells(1, 10) = "MODIFIED"
On Error Resume Next
For Each ffile In fc
No = No + 1
Cells(No, 1) = No - 1
Cells(No, 2) = ffile.Name
Cells(No, 3) = ffile.Size
Cells(No, 4) = fs.GetExtensionName(ffile)
Cells(No, 5) = FindFileAttributes(ffile)
Cells(No, 6) = ffile.Files.Count + Files_Count(ffile.Path)
Cells(No, 7) = ffile.SubFolders.Count + Folder_Count(ffile.Path)
Cells(No, 8) = ffile.DateCreated
Cells(No, 9) = ffile.DateLastAccessed
Cells(No, 10) = ffile.dateLastModified
Next
Range("A1:J1").Font.Bold = True
Range("A1:J1").HorizontalAlignment = xlCenter
Range(Cells(1, 2), Cells(No, 9)).Select
Selection.Sort _
Key1:=Range("B2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Cells.EntireColumn.AutoFit
Range(Cells(1, 1), Cells(No, 10)).Select
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeLeft).Weight = xlThin
Selection.Borders(xlEdgeLeft).ColorIndex = xlAutomatic
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).Weight = xlThin
Selection.Borders(xlEdgeTop).ColorIndex = xlAutomatic
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).Weight = xlThin
Selection.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).Weight = xlThin
Selection.Borders(xlEdgeRight).ColorIndex = xlAutomatic
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).Weight = xlThin
Selection.Borders(xlInsideVertical).ColorIndex = xlAutomatic
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).Weight = xlThin
Selection.Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
Range(Cells(2, 3), Cells(No, 3)).NumberFormat = "#,##0"
Range(Cells(2, 6), Cells(No, 6)).NumberFormat = "#,##"
ActiveWindow.DisplayGridlines = False
Range("A1").Select
Selection.Activate
End If
Exit Sub
SheetNameError:
PAVLA = " -"
No = No + 1
Resume
GoTo NextName
End Sub
Sub ImportFileInfo()
If ActiveSheet Is Nothing Then
MsgBox "There is no Active Workbook !!!"
Exit Sub
End If
Dim DirPath, FileSaveName
FileSaveName = Application.GetSaveAsFilename( _
"Select This Folder", _
Title:="Open The Folder And Click The [Save] Button")
If FileSaveName <> False Then
DirPath = Left(FileSaveName, Len(FileSaveName) - 19)
shPATH = DirPath
PathSep = 0
For i = (Len(DirPath) - 1) To 1 Step -1
If Mid(DirPath, i, 1) = Application.PathSeparator Then
PathSep = 1
DirName = Mid(DirPath, i + 1, Len(DirPath))
ShName = "FILE_INFO"
Exit For
End If
Next
If PathSep = 0 Then
DirName = Left(DirPath, Len(DirPath) - 1)
ShName = "ROOT " + Mid(DirName, 1, Len(DirName) - 1) + " Files"
End If
Dim fs, f, fc, ffile
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(DirPath)
Set fc = f.SubFolders
Dim No
PAVLA = ""
On Error GoTo SheetNameError
Set NewSheet = Worksheets.Add
NextName:
NewSheet.Name = ShName & PAVLA & No
On Error Resume Next
Cells(1, 1) = "A/A"
Cells(1, 2) = "FILENAME"
Cells(1, 3) = "SIZE"
Cells(1, 4) = "EXT"
Cells(1, 5) = "TYPE"
Cells(1, 6) = "ATTRIBUTES"
Cells(1, 7) = "CREATED"
Cells(1, 8) = "ACCESSED"
Cells(1, 9) = "MODIFIED"
No = 1
For Each ffile In f.Files
No = No + 1
Cells(No, 1) = No - 1
Cells(No, 2) = ffile.Name
Cells(No, 3) = ffile.Size
Cells(No, 4) = fs.GetExtensionName(ffile)
Cells(No, 5) = ffile.Type
Cells(No, 6) = FindFileAttributes(ffile)
Cells(No, 7) = ffile.DateCreated
Cells(No, 8) = ffile.DateLastAccessed
Cells(No, 9) = ffile.dateLastModified
Next
Range("A1:I1").Font.Bold = True
Range("A1:I1").HorizontalAlignment = xlCenter
Range(Cells(1, 2), Cells(No, 9)).Select
Selection.Sort _
Key1:=Range("D2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Cells.EntireColumn.AutoFit
Range(Cells(1, 1), Cells(No, 9)).Select
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeLeft).Weight = xlThin
Selection.Borders(xlEdgeLeft).ColorIndex = xlAutomatic
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).Weight = xlThin
Selection.Borders(xlEdgeTop).ColorIndex = xlAutomatic
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).Weight = xlThin
Selection.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).Weight = xlThin
Selection.Borders(xlEdgeRight).ColorIndex = xlAutomatic
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).Weight = xlThin
Selection.Borders(xlInsideVertical).ColorIndex = xlAutomatic
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).Weight = xlThin
Selection.Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
Range(Cells(2, 3), Cells(No, 3)).NumberFormat = "#,##0"
ActiveWindow.DisplayGridlines = False
Range("A1").Select
Selection.Activate
End If
Exit Sub
SheetNameError:
PAVLA = " -"
No = No + 1
Resume
GoTo NextName
End Sub
Sub AddAttribute(HasAttribute, ByRef fAttr As String, ByVal sAttribute As String)
If HasAttribute <> 0 Then fAttr = fAttr & sAttribute & ", "
End Sub
Function FindFileAttributes(cfile)
Dim fAttr As String
AddAttribute cfile.Attributes And 16, fAttr, "Dir"
AddAttribute cfile.Attributes And 8, fAttr, "Vol"
AddAttribute cfile.Attributes And 0, fAttr, "Nor"
AddAttribute cfile.Attributes And 1, fAttr, "Read"
AddAttribute cfile.Attributes And 2, fAttr, "Hid"
AddAttribute cfile.Attributes And 4, fAttr, "Sys"
AddAttribute cfile.Attributes And 32, fAttr, "Arc"
AddAttribute cfile.Attributes And 64, fAttr, "Alias"
AddAttribute cfile.Attributes And 128, fAttr, "Com"
If fAttr <> "" Then FindFileAttributes = Left(fAttr, Len(fAttr) - 2)
End Function
Function Files_Count(SearchDirPath) As Long
On Error Resume Next
Dim FileSystem, sFolder, sSubFolder, sItem
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Set sFolder = FileSystem.GetFolder(SearchDirPath)
Set sSubFolder = sFolder.SubFolders
For Each sItem In sSubFolder
Files_Count = Files_Count + sItem.Files.Count
Files_Count = Files_Count + Files_Count(sItem.Path)
Next
End Function
Function Folder_Count(SearchDirPath) As Long
On Error Resume Next
Dim FileSystem, sFolder, sSubFolder, sItem
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Set sFolder = FileSystem.GetFolder(SearchDirPath)
Set sSubFolder = sFolder.SubFolders
For Each sItem In sSubFolder
Folder_Count = Folder_Count + sItem.SubFolders.Count
Folder_Count = Folder_Count + Folder_Count(sItem.Path)
Next
End Function