Creating a Table of Contents in Word based on File Names

[MaxPowerz2]

I am compiling a list of all of our documents inside one folder using subfolders. Basically I need a list of every document inside the folders using the foldername and filename. Basically I want my Word document to look like this:

I. Main Folder
A.) Folder 1
1.) SubFolder 1
a.) Filename 1
b.) Filename 2
c.) Filename 3
B.) Folder 2
1.) Subfolder 1
a.) Filename 4
b.) Filename 5
Etc...

Ideally I would like to use a macro that could automate this process by simply specifying the Main Folder.

Thanks in advance!

 

[BrianB]

An interesting exercise because I just had to adapt some existing Excel code. My use of Selection shows my inexpertise in this area.

'=====================================================================================
'- ** WORD MACRO ** TO LIST FOLDERS & FILES
'- For Excel version see : http://www.mrexcel.com/board2/viewtopic.php?t=277766
'- Brian Baulsom November 2008
'=====================================================================================
Dim BaseFolder As String
Dim MySheet As Object
Dim MyRange As Range
Dim MyLine As String        ' line typed in document
'------------------------------------------------------
Dim FSO As Object           ' FileSystemObject
Dim FolderName As String
Dim FolderPath As String
Dim FolderSpec As String
Dim FileSpec As String
'=====================================================================================
'- MAIN ROUTINE : SET START FOLDER & GET ITS FILES - THEN GET SUB FOLDERS
'=====================================================================================
Sub LIST_FOLDERS_FILES()
    '- GET BASE FOLDER
    BaseFolder = "F:\TEST\"
    ChDrive BaseFolder
    ChDir BaseFolder
    '---------------------------------------------------------------------------------
    '- initialise variables
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set MySheet = ActiveDocument
    '---------------------------------------------------------------------------------
    '- CLEAR EXISTING DATA
    Set MyRange = MySheet.Range(Start:=0)
    With MyRange
        .WholeStory
        .Delete
    End With
    '---------------------------------------------------------------------------------
    '- NEW HEADING
    With Selection
        .TypeText Text:="INDEX FOR " & BaseFolder
        .HomeKey Unit:=wdLine
        .EndKey Unit:=wdLine, Extend:=wdExtend
        .Font.Size = 18
        .Font.Bold = True
        .EndKey Unit:=wdLine
        .TypeParagraph
        .TypeParagraph
    End With
    '--------------------------------------------------------------------------------
    '- CALL FILE SUBROUTINE FOR BASE FOLDER
    Application.StatusBar = BaseFolder
    ShowFileList (BaseFolder)
    '-------------------------------------------------------------------------------
    '- CALL FOLDER SUBROUTINE (WHICH CALLS THE FILE ROUTINE)
    ShowFolderList (BaseFolder)
    '-------------------------------------------------------------------------------
    '- FINISH
    MsgBox ("Done")
    Application.StatusBar = False
End Sub
'========  END OF MAIN ROUTINE =======================================================
'=====================================================================================
'- SUBROUTINE : GET SUBFOLDERS OF SPECIFIED FOLDER
'=====================================================================================
Private Sub ShowFolderList(FolderSpec)
    Dim f, f1, fc, s
    Set f = FSO.GetFolder(FolderSpec)
    Set fc = f.subfolders
    '---------------------------------------------------------------------------------
    '- CHECK SUBFOLDER COUNT
    If fc.Count = 0 Then
        Exit Sub
    Else
        '- LOOP FOLDERS
        For Each f1 In fc
            FolderName = f1.Path
            Application.StatusBar = FolderName
            '------------------------------------------------------------------------
            '- DATA TO SHEET
            MyLine = FolderName
            With Selection
                .TypeText Text:=MyLine
                .HomeKey Unit:=wdLine
                .EndKey Unit:=wdLine, Extend:=wdExtend
                .Font.Size = 16
                .Range.Bold = True
                .EndKey Unit:=wdLine
                .TypeParagraph
            End With
            '-----------------------------------------------------------------------
            '- GET FILES
            ShowFileList (FolderName)
            '-----------------------------------------------------------------------
            '- CALL SELF TO GET ANY SUBFOLDERS IN THIS SUBFOLDER
            ShowFolderList (FolderName)
            '------------------------------------------------------------------------
        Next
    End If
    '--------------------------------------------------------------------------------
End Sub
'-
'=====================================================================================
'- SUBROUTINE : TO LIST FILES IN FOLDER
'=====================================================================================
Private Sub ShowFileList(FileSpec)
    Dim f, f1, fc, Spec
    Set f = FSO.GetFolder(FileSpec)
    Set fc = f.Files
    '--------------------------------------------------------------------------------
    '- CHECK FILE COUNT
    If fc.Count = 0 Then
        Selection.TypeParagraph
        Exit Sub
    Else
        '- LOOP FILES
        For Each f1 In fc
            Set Spec = FSO.GetFile(f1)  ' individual file info
            '------------------------------------------------------------------------
            '- DATA TO SHEET
            MyLine = vbTab & f1.Name _
                   & vbTab & Format(Spec.datecreated, "DD/MM/YY") _
                   & vbTab & Format(Spec.Size, "###,###,##0")
             With Selection
                .TypeText Text:=MyLine
                .HomeKey Unit:=wdLine
                .EndKey Unit:=wdLine, Extend:=wdExtend
                .Font.Size = 14
                .Range.Bold = False
                .EndKey Unit:=wdLine
                .TypeParagraph
            End With
            '------------------------------------------------------------------------
        Next
    End If
    '---------------------------------------------------------------------------------
End Sub
'=== END OF PROJECT ==================================================================__________________