Option Explicit
Dim FSO As New Scripting.FileSystemObject
Dim DateiArr() As String
Dim Anz As Long
Dim Pattern(2) As String
Dim SWArr() As String
 
Sub KomplProjecteAnzeigen()
    Dim Root As Folder, Verz As Folder
    Set Root = FSO.GetFolder("D:\TV3DSDK\VB\Tutorials")
    Set Root = FSO.GetFolder("D:\TV3DSDK\VB\Samples")
    Selection.WholeStory
    Selection.Delete Unit:=wdCharacter, Count:=1
    Selection.Font.Name = "Courier"
    For Each Verz In Root.SubFolders
        Application.StatusBar = Verz.Path
        Selection.Font.Size = 10
        Selection.Font.Bold = True
        Selection.Font.Underline = wdUnderlineSingle
        Selection.TypeText Text:=Verz.Path & vbCrLf & vbCrLf
        Selection.Font.Bold = False
        Selection.Font.Underline = wdUnderlineNone
        Selection.Font.Size = 8
        ProjectDatenAnzeigen Verz.Path
        Selection.InsertBreak Type:=wdPageBreak
    Next Verz
    LayoutAnpassen
    Selection.Start = 0
    Selection.End = 0
End Sub
Sub ProjectDatenAnzeigen(Verz As String)
    Dim Root As Folder
    Dim n As Long, i As Byte
    Dim FF As Long
    Dim Zeile As String
 
    Pattern(0) = "frm"
    Pattern(1) = "bas"
    Pattern(2) = "cls"
    FF = FreeFile
    ReDim SWArr(0)
    Open ActiveDocument.Path & "\SW.txt" For Input As #FF
    Anz = 0
    While Not EOF(FF)
        Line Input #FF, Zeile
        If Zeile <> "" Then
            ReDim Preserve SWArr(Anz): Anz = Anz + 1
            SWArr(Anz - 1) = LCase(Zeile)
        End If
    Wend
    Close #FF
    Anz = 0
    Set Root = FSO.GetFolder(Verz)
    FindeDateien Root
    Selection.Font.Bold = True
    Selection.Font.Underline = wdUnderlineSingle
    Selection.TypeText Text:="Projekt-Dateien:" & vbCrLf
    Selection.Font.Bold = False
    Selection.Font.Underline = wdUnderlineNone
    For n = 0 To Anz - 1
        Selection.TypeText Text:=DateiArr(n) & vbCrLf
    Next n
    Selection.TypeText Text:=vbCrLf
    For n = 0 To Anz - 1
        For i = 0 To UBound(Pattern)
            If LCase(Right(DateiArr(n), 3)) = Pattern(i) Then
                Selection.Font.Bold = True
                Selection.TypeText Text:="Datei: " & DateiArr(n) & vbCrLf
                Selection.Font.Bold = False
                DateiEinlesen DateiArr(n)
            End If
        Next i
    Next n
End Sub
 
Sub LayoutAnpassen()
    Dim Farbe As WdColor
    Dim Kursiv As Boolean
    Dim SW As Variant
    Selection.Start = 0
    Selection.End = 0
    Farbe = wdColorAutomatic
    Kursiv = False
    Do
        Application.StatusBar = "Zeile " & Selection.Start & " von " & _
          ActiveDocument.Content.StoryLength
        Selection.Start = Selection.End
        Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
        If Left(Trim(LCase(Selection.Text)), 1) = "'" Then
            Selection.End = Selection.Start + InStr(1, Selection.Text, "'")
        End If
        Select Case Trim(LCase(Selection.Text))
            Case "'"
                Kursiv = True
                Farbe = wdColorGreen
            Case vbCr
                Farbe = wdColorAutomatic
                Kursiv = False
            Case """"
                If Farbe = wdColorAutomatic Then
                    Farbe = wdColorBrown
                End If
            Case Else
                For Each SW In SWArr
                    If Trim(LCase(Selection.Text)) = SW Then
                        If Farbe = wdColorAutomatic Then
                            Selection.Font.Color = wdColorBlue
                            Selection.Font.Bold = True
                            Selection.Start = Selection.End
                            Exit For
                        End If
                    End If
                Next SW
        End Select
        Selection.Font.Color = Farbe
        Selection.Font.Italic = Kursiv
    Loop While Not Selection.End = ActiveDocument.Content.StoryLength
End Sub
Sub FindeDateien(Verz As Folder)
    Dim Datei As File, V As Folder
 
    For Each Datei In Verz.Files
        ReDim Preserve DateiArr(Anz): Anz = Anz + 1
        DateiArr(Anz - 1) = Datei
        'Debug.Print Datei
    Next Datei
    For Each V In Verz.SubFolders
        FindeDateien V
    Next V
End Sub
 
Sub DateiEinlesen(Datei As String)
    Dim FF As Long, Zeile As String
    FF = FreeFile
    Open Datei For Input As #FF
    While Not EOF(FF)
        Line Input #FF, Zeile
        Selection.TypeText Text:=Zeile & vbCrLf
    Wend
    Close #FF
End Sub