brownnr
01-26-2015, 01:00 PM
I've used, and adapted the VBA(shown below) to list a "Table of Contents" style directory tree to a new word document, but I need help in the order of it outputting the files and folders...it currently lists all files and folders alphabetically, but I'd like it to print it alphabetically and by file type, i.e. all the folders first then all the files, in each level; similar to what you would actually see in the file dialog box.
Current Output
Desired Output
Folder
Folder
File
File
File
Folder
Folder
Folder
Folder
Folder
File
File
Folder
File
Here's the code:
Private Sub CommandButton1_Click()
Get_Folder_Structure
'Select everything and formats the list numbering after printing folder structure to document
Application.ScreenUpdating = False
Selection.WholeStory
If ActiveDocument.Characters.Count > 1 Then
With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1)
.NumberFormat = "%1."
.TrailingCharacter = wdTrailingTab
.NumberStyle = wdListNumberStyleArabic
.NumberPosition = InchesToPoints(0.25)
.Alignment = wdListLevelAlignLeft
.TextPosition = InchesToPoints(0.5)
.TabPosition = wdUndefined
.ResetOnHigher = 0
.StartAt = 1
End With
ListGalleries(wdNumberGallery).ListTemplates(1).Name = ""
Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdNumberGallery).ListTemplates(1), ContinuePreviousList:= _
False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _
wdWord10ListBehavior
Selection.MoveDown Unit:=wdLine, Count:=1
Else
ActiveDocument.Close savechanges:=False
Exit Sub
End If
Application.ScreenUpdating = True
End Sub
'Main procedure
Sub Get_Folder_Structure()
Dim search_Folder As String
'Create new document
Documents.Add
search_Folder = Select_Folder_From_Prompt()
Selection.Font.Bold = True
Selection.Font.Italic = True
Selection.Font.AllCaps = True
If search_Folder <> "" Then
Call List_subfolder_structure(search_Folder, 1)
End If
End Sub
'File selecting function to pick folder
Function Select_Folder_From_Prompt() As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select a folder"
.AllowMultiSelect = False
.InitialFileName = "I:\"
.Filters.Clear
'Use the Show method to display the File Picker dialog box and return the user's action.
If .Show = -1 Then
Select_Folder_From_Prompt = .SelectedItems(1) & "\"
End If
End With
End Function
'Recursive function that looks at folder structure
Function List_subfolder_structure(FolderPath As String, number_of_levels As Integer)
Dim number_of_files As Integer
Dim file_count As Integer
Dim file_name As String
Dim level_count As Integer
Dim file_Path As String
'lists the names of all files in the specified directory
number_of_files = 0
level_count = 0
On Error Resume Next
file_name = Dir(FolderPath & "*.*", vbDirectory)
Dim fileType As String
'File loop
Do While ((file_name) <> "")
' See if we should skip this file.
If ((file_name <> ".") And (file_name <> "..")) Then
'reset level counters
level_count = 1
'Level loop
Do While (number_of_levels > level_count)
Selection.TypeText Text:=vbTab
level_count = level_count + 1
Loop
Selection.TypeText (file_name)
Selection.TypeParagraph
fileType = getFileType(FolderPath & file_name)
If (fileType = "Folder") Then
number_of_levels = number_of_levels + 1
file_Path = FolderPath & file_name & "\"
Call List_subfolder_structure(file_Path, number_of_levels)
'reset levels
number_of_levels = number_of_levels - 1
ElseIf (fileType = "File") Then
With Selection
.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
.Font.Italic = wdToggle
.Font.Bold = wdToggle
.MoveDown Unit:=wdLine, Count:=1
End With
End If
End If
number_of_files = number_of_files + 1
file_name = Dir(FolderPath & "*.*", vbDirectory)
'Reset to get next file
Do While (file_count < number_of_files And file_name <> "")
file_name = Dir
file_count = file_count + 1
Loop
'reset file counter
file_count = 0
Loop
End Function
'Determine if file is a folder
Function getFileType(file As String) As String
'The GetAttr will return the vbDirectory flag
fileAttribute = (GetAttr(file) And vbDirectory)
If fileAttribute = vbDirectory Then
getFileType = "Folder"
Else
getFileType = "File"
End If
End Function
Current Output
Desired Output
Folder
Folder
File
File
File
Folder
Folder
Folder
Folder
Folder
File
File
Folder
File
Here's the code:
Private Sub CommandButton1_Click()
Get_Folder_Structure
'Select everything and formats the list numbering after printing folder structure to document
Application.ScreenUpdating = False
Selection.WholeStory
If ActiveDocument.Characters.Count > 1 Then
With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1)
.NumberFormat = "%1."
.TrailingCharacter = wdTrailingTab
.NumberStyle = wdListNumberStyleArabic
.NumberPosition = InchesToPoints(0.25)
.Alignment = wdListLevelAlignLeft
.TextPosition = InchesToPoints(0.5)
.TabPosition = wdUndefined
.ResetOnHigher = 0
.StartAt = 1
End With
ListGalleries(wdNumberGallery).ListTemplates(1).Name = ""
Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdNumberGallery).ListTemplates(1), ContinuePreviousList:= _
False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _
wdWord10ListBehavior
Selection.MoveDown Unit:=wdLine, Count:=1
Else
ActiveDocument.Close savechanges:=False
Exit Sub
End If
Application.ScreenUpdating = True
End Sub
'Main procedure
Sub Get_Folder_Structure()
Dim search_Folder As String
'Create new document
Documents.Add
search_Folder = Select_Folder_From_Prompt()
Selection.Font.Bold = True
Selection.Font.Italic = True
Selection.Font.AllCaps = True
If search_Folder <> "" Then
Call List_subfolder_structure(search_Folder, 1)
End If
End Sub
'File selecting function to pick folder
Function Select_Folder_From_Prompt() As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select a folder"
.AllowMultiSelect = False
.InitialFileName = "I:\"
.Filters.Clear
'Use the Show method to display the File Picker dialog box and return the user's action.
If .Show = -1 Then
Select_Folder_From_Prompt = .SelectedItems(1) & "\"
End If
End With
End Function
'Recursive function that looks at folder structure
Function List_subfolder_structure(FolderPath As String, number_of_levels As Integer)
Dim number_of_files As Integer
Dim file_count As Integer
Dim file_name As String
Dim level_count As Integer
Dim file_Path As String
'lists the names of all files in the specified directory
number_of_files = 0
level_count = 0
On Error Resume Next
file_name = Dir(FolderPath & "*.*", vbDirectory)
Dim fileType As String
'File loop
Do While ((file_name) <> "")
' See if we should skip this file.
If ((file_name <> ".") And (file_name <> "..")) Then
'reset level counters
level_count = 1
'Level loop
Do While (number_of_levels > level_count)
Selection.TypeText Text:=vbTab
level_count = level_count + 1
Loop
Selection.TypeText (file_name)
Selection.TypeParagraph
fileType = getFileType(FolderPath & file_name)
If (fileType = "Folder") Then
number_of_levels = number_of_levels + 1
file_Path = FolderPath & file_name & "\"
Call List_subfolder_structure(file_Path, number_of_levels)
'reset levels
number_of_levels = number_of_levels - 1
ElseIf (fileType = "File") Then
With Selection
.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
.Font.Italic = wdToggle
.Font.Bold = wdToggle
.MoveDown Unit:=wdLine, Count:=1
End With
End If
End If
number_of_files = number_of_files + 1
file_name = Dir(FolderPath & "*.*", vbDirectory)
'Reset to get next file
Do While (file_count < number_of_files And file_name <> "")
file_name = Dir
file_count = file_count + 1
Loop
'reset file counter
file_count = 0
Loop
End Function
'Determine if file is a folder
Function getFileType(file As String) As String
'The GetAttr will return the vbDirectory flag
fileAttribute = (GetAttr(file) And vbDirectory)
If fileAttribute = vbDirectory Then
getFileType = "Folder"
Else
getFileType = "File"
End If
End Function