PDA

View Full Version : Display a list of the folders and subfolders in VBA



dm28949
01-30-2015, 09:17 AM
First time posting in this forum!!! I found a KB entry by brettdj in this forum that lists the file atrributes of folders and subfolders. What I want to do is list the properties of folders and subfoldes in high level not the files contained in the subfolders. I would appreciate any help on how to do that.

For example:
Main folder: Database
Folders contained by main folder: SQL, Access, Oracle
Folders contained by SQL: Data2010, Data 2011 etc
Folders contained by Access: A, B, C, D, E etc
Is it possible to list just the properties of SQL, Access and oracle but not the folders inside of them?


I am absolutely new to programming and struggling to get this done.


Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil

Sub MainExtractData()

Dim NewSht As Worksheet
Dim MainFolderName As String
Dim TimeLimit As Long, StartTime As Double

ReDim X(1 To 65536, 1 To 11)

Set objShell = CreateObject("Shell.Application")
TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _
"Leave this at zero for unlimited runtime", "Time Check box", 0)
StartTime = Timer

Application.ScreenUpdating = False
MainFolderName = BrowseForFolder()
Set NewSht = ThisWorkbook.Sheets.Add

X(1, 1) = "Path"
X(1, 2) = "File Name"
X(1, 3) = "Last Accessed"
X(1, 4) = "Last Modified"
X(1, 5) = "Created"
X(1, 6) = "Type"
X(1, 7) = "Size"
X(1, 8) = "Owner"
X(1, 9) = "Author"
X(1, 10) = "Title"
X(1, 11) = "Comments"

i = 1

Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)
'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
On Error Resume Next
For Each Fil In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
i = i + 1
If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
GoTo FastExit
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
X(i, 1) = oFolder.path
X(i, 2) = Fil.Name
X(i, 3) = Fil.DateLastAccessed
X(i, 4) = Fil.DateLastModified
X(i, 5) = Fil.DateCreated
X(i, 6) = Fil.Type
X(i, 7) = Fil.Size
X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Next

'Get subdirectories
If TimeLimit = 0 Then
Call RecursiveFolder(oFolder, 0)
Else
If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
End If

FastExit:
Range("A:K") = X
If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
Range("A:K").WrapText = False
Range("A:K").EntireColumn.AutoFit
Range("1:1").Font.Bold = True
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Range("a1").Activate

Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
Application.StatusBar = ""
Application.ScreenUpdating = True
End Sub

Sub RecursiveFolder(xFolder, TimeTest As Long)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
Set objFolder = objShell.Namespace(SubFld.path)
For Each Fil In SubFld.Files
Set objFolder = objShell.Namespace(oFolder.path)
'Problem with objFolder at times
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(Fil.Name)
i = i + 1
If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
Exit Sub
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
X(i, 1) = SubFld.path
X(i, 2) = Fil.Name
X(i, 3) = Fil.DateLastAccessed
X(i, 4) = Fil.DateLastModified
X(i, 5) = Fil.DateCreated
X(i, 6) = Fil.Type
X(i, 7) = Fil.Size
X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Else
Debug.Print Fil.path & " " & Fil.Name
End If
Next
Call RecursiveFolder(SubFld, TimeTest)
Next
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function

Bob Phillips
01-30-2015, 10:04 AM
Option Explicit

Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil

Sub MainExtractData()
Dim NewSht As Worksheet
Dim MainFolderName As String
Dim TimeLimit As Long, StartTime As Double

ReDim X(1 To 65536, 1 To 6)

Set objShell = CreateObject("Shell.Application")
TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _
"Leave this at zero for unlimited runtime", "Time Check box", 0)
StartTime = Timer

Application.ScreenUpdating = False
MainFolderName = BrowseForFolder()
If MainFolderName <> "" Then

Set NewSht = ThisWorkbook.Sheets.Add

X(1, 1) = "Path"
X(1, 2) = "Last Accessed"
X(1, 3) = "Last Modified"
X(1, 4) = "Created"
X(1, 5) = "Size"
X(1, 6) = "IsRootFolder"

i = 1

Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)

i = i + 1
X(i, 1) = oFolder.Path
X(i, 2) = oFolder.DateLastAccessed
X(i, 3) = oFolder.DateLastModified
X(i, 4) = oFolder.DateCreated
X(i, 5) = oFolder.Size
X(i, 6) = oFolder.IsRootFolder

'Get subdirectories
If TimeLimit = 0 Then

Call RecursiveFolder(oFolder, 0)
Else

If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
End If

FastExit:
Range("A:F") = X
If i < Rows.Count - 1 Then Range(Cells(i + 1, "A"), Cells(Rows.Count, "A")).EntireRow.Delete
Range("A:K").WrapText = False
Range("A:K").EntireColumn.AutoFit
Range("1:1").Font.Bold = True
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Range("a1").Activate

Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
End If

Application.StatusBar = ""
Application.ScreenUpdating = True
End Sub

Sub RecursiveFolder(xFolder, TimeTest As Long)
Dim SubFld
For Each SubFld In xFolder.SubFolders

Set oFolder = FSO.GetFolder(SubFld)
Set objFolder = objShell.Namespace(SubFld.Path)

i = i + 1
X(i, 1) = oFolder.Path
X(i, 2) = oFolder.DateLastAccessed
X(i, 3) = oFolder.DateLastModified
X(i, 4) = oFolder.DateCreated
X(i, 5) = oFolder.Size
X(i, 6) = oFolder.IsRootFolder

Call RecursiveFolder(SubFld, TimeTest)
Next
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim foldername As String

With Application.FileDialog(msoFileDialogFolderPicker)

.AllowMultiSelect = False
If .Show = -1 Then

BrowseForFolder = .SelectedItems(1)
End If
End With

End Function

dm28949
02-02-2015, 08:18 AM
How do I convert the size to say KB?

dm28949
02-02-2015, 08:23 AM
How do I convert the size to say KB?

Also, I only want to access the folders to certain level. I wanna access subfolders and the folders contained by subfolders not the hundreds of folders inside of them.

Bob Phillips
02-02-2015, 04:05 PM
KB - divide by 1000.

If you want at a certain level, add a public vraiant to count each call and when it exceeds your designated level number, exit immediately.

snb
02-03-2015, 01:47 AM
Sub M_snb()
With CreateObject("wscript.shell")
For Each it In Array("SQL", "Access", "Oracle")
c00 = c00 & vbCrLf & "G:\Database\" & it & Replace(.exec("cmd /c Dir G:\Database\" & it & "*.* /b").stdout.readall, vbCrLf, vbCrLf & "G:\Database\" & it) & "|"
Next
End With

sn = filter(Filter(Split(c00, vbCrLf), "|", False),"\")
ReDim sp(UBound(sn), 10)

With CreateObject("scripting.filesystemobject")
For j = 0 To UBound(sn)
With .getfile(sn(j))
sp(j, 0) = sn(j)
sp(j, 1) = .Parent
sp(j, 2) = .Name
sp(j, 3) = FileDateTime(sn(j))
sp(j, 4) = .DateLastModified
sp(j, 5) = .DateCreated
sp(j, 6) = .Type
sp(j, 7) = FileLen(sn(j))
Next

sheet1.cells(1).resize(Ubound(sp)+1,ubound(sp,2)+1)=sp
End Sub
More on fileproperties:

http://www.snb-vba.eu/VBA_Bestanden_en.html

dm28949
02-03-2015, 07:10 AM
Thank you very much. This forum is awesome!