List all Sub-folders of a Folder

VBA has the capablility to list all sub-folders of a folder. The same macro code is used to get the sub-folders using Excel, Word or PowerPoint. To list the sub-folders the code is different. I used the three functions: DISPLAY_EXCEL, DISPLAY_WORD AND DISPLAY_POWERPOINT to list each application.

SAS Fifth Dimension Macro-SubFolders

Review the following code, copy it to Excel, Word or PowerPoing and execute it.

Public LIBRARY_NAMES(500), LIBRARY_SIZE
Sub LIST_SUB_FOLDERS_EXCEL()
' Display sub-folders
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set CDIR = FSO.GetFolder(CurDir())
    Set SubFS = CDIR.SubFolders
    LIBRARY_SIZE = 0
    For Each SubF In SubFS
        LIBRARY_SIZE = LIBRARY_SIZE + 1
        LIBRARY_NAMES(LIBRARY_SIZE) = SubF.NAME
    Next
    HEAD = "Sub-directories in directory " & CURDIR()
    If InStr(Application.Name, "Excel") _
    Then RC = DISPLAY_EXCEL(HEAD)
    If InStr(Application.Name, "Word") _
    Then RC = DISPLAY_WORD(HEAD)
    If InStr(Application.Name, "PowerPoint") _
    Then RC = DISPLAY_POWERPOINT(HEAD)
ENDIT:
End Sub
Function DISPLAY_EXCEL(HEAD)
' copy list of file to a new worksheet
     Workbooks.Add
     For II = 1 To LIBRARY_SIZE
         Cells(II, 1) = LIBRARY_NAMES(II)
     Next
     Cells(1, 1).Select
     Selection.Insert Shift:=xlDown
     Cells(1, 1) = HEAD
     Columns("A").EntireColumn.AutoFit
     Cells(1, 1).Select
     ActiveWorkbook.Saved = True
End Function
Function DISPLAY_WORD(HEAD)
' Copy list of files to a new document
    Documents.Add
    Selection.TypeText Text:=HEAD
    Selection.TypeParagraph
    Selection.TypeParagraph
    For II = 1 To LIBRARY_SIZE
        Selection.TypeText Text:=LIBRARY_NAMES(II)
        Selection.TypeParagraph
    Next
    ActiveDocument.Saved = True
End Function
Function DISPLAY_POWERPOINT(HEAD)
' Copy list of files to a new presentation
    For II = 1 To LIBRARY_SIZE
        MSG = MSG & LIBRARY_NAMES(II) & _ 
              Chr$(CharCode:=13)
    Next
    Presentations.Add WithWindow:=msoTrue
    ActiveWindow.View.GotoSlide _
     Index:=ActivePRESENTATION.Slides.Add(Index:=1, _
     Layout:=ppLayoutText).SlideIndex
    ActiveWindow.Selection.SlideRange.Shapes _ 
     ("Rectangle 2").Select
    ActiveWindow.Selection.ShapeRange.TextFrame. _ 
     TextRange.Select
    ActiveWindow.Selection.ShapeRange.TextFrame. _ 
     TextRange.Characters (Start:=1, Length:=0).Select
    ActiveWindow.Selection.TextRange.Text = HEAD
    ActiveWindow.Selection.SlideRange.Shapes _
     ("Rectangle 3").Select
    ActiveWindow.Selection.ShapeRange.TextFrame. _ 
     TextRange.Select
    ActiveWindow.Selection.ShapeRange.TextFrame. _ 
     TextRange.Characters _
     (Start:=1, Length:=0).Select
    ActiveWindow.Selection.TextRange.Text = MSG
    ActivePRESENTATION.Saved = True
End Function