Sub ListMacros2()  
' Durchläuft alle verfügbaren Vorlagen und Add-Ins und  
' listet in allen Modulen/USerForms/Klassenmodulen die  
' Prozedurnamen auf.  
' Zusätzlich wird noch angezeigt, wie viele 'Sub' und 'Function' in dem  
' jeweiligen Modul/UserForm etc. vorhanden sind.  
System.Cursor = wdCursorWait
' Tabellenspaltenbreite  
Const c1 As Integer = "15"
Const c2 As Integer = "15"
Const c3 As Integer = "75"
Const c4 As Integer = "15"
Const c5 As Integer = "35"
Dim oApp As Word.Application, rng As Range, tbl As Table, s As String, s1 As String, rw As Row
Dim myProject As VBProject
Dim myComponent As VBComponent
Dim strNames As Variant, strDocNames As String
Dim strFile() As String
Dim iCount As Long, iProz As Integer, strProz As String, iCountProz As Integer
Dim iCountSub As Integer, iCountFkt As Integer
Dim iFkt As Integer, iSub As Integer
Dim strProc As String
' Alle Projekte durchlaufen  
' In Dokument ausgeben  
Dim oDoc As Document
Set oDoc = Documents.Add
oDoc.DefaultTabStop = MillimetersToPoints(15)
  oDoc.Content.ParagraphFormat.TabStops.Add Position:=MillimetersToPoints(150), _
     Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces
Set oApp = GetObject(, "Word.Application")
For Each myProject In VBE.VBProjects
strNames = ""
DoEvents
' Nur ungeschützte Projekte berücksichtigen  
If myProject.Protection = vbext_pp_none Then
  On Error Resume Next
  If myProject.VBComponents.Count > 1 Then
    Set rng = oDoc.Range
    rng.Start = rng.End
    Set tbl = oDoc.Tables.Add(rng, 1, 5)
    tbl.Borders.Enable = False
    With tbl
      .Columns(1).Width = MillimetersToPoints(c1)
      .Columns(2).Width = MillimetersToPoints(c2)
      .Columns(3).Width = MillimetersToPoints(c3)
      .Columns(4).Width = MillimetersToPoints(c4)
      .Columns(5).Width = MillimetersToPoints(c5)
    End With
    strFile() = Split(myProject.FileName, "\")
    strNames = myProject.Name & " (" & strFile(UBound(strFile())) & ")" & vbCrLf
    s = myProject.Name & " (" & strFile(UBound(strFile())) & ")"
    tbl.Rows(1).Cells.Merge
    tbl.Cell(1, 1).Range.Text = s
    iCountProz = 0
    On Error GoTo 0
    ' Alle Module durchlaufen  
    For Each myComponent In myProject.VBComponents
      With myComponent
      ' Modul-Typ ermitteln  
      If .Type = vbext_ct_StdModule Then
        strProz = vbTab & .Name & " (bas)" & vbCrLf
        s = .Name & " (bas)"
      ElseIf .Type = vbext_ct_ClassModule Then
        strProz = vbTab & .Name & " (cls)" & vbCrLf
        s = .Name & " (cls)"
      ElseIf .Type = vbext_ct_MSForm Then
        strProz = vbTab & .Name & " (frm)" & vbCrLf
        s = .Name & " (frm)"
      ElseIf .Type = vbext_ct_Document Then
        strProz = vbTab & .Name & " (doc)" & vbCrLf
        s = .Name & " (doc)"
      End If
      tbl.Rows.Add
      If tbl.Range.Cells.Count <> 5 Then tbl.Rows.Last.Cells.Split 1, 5, True
      With tbl.Rows.Last
        .Cells(1).Width = MillimetersToPoints(c1)
        .Cells(2).Width = MillimetersToPoints(c2)
        .Cells(3).Width = MillimetersToPoints(c3)
        .Cells(4).Width = MillimetersToPoints(c4)
        .Cells(5).Width = MillimetersToPoints(c5)
      End With
      tbl.Rows.Last.Cells(2).Range.Text = s
      Set rw = tbl.Rows.Last
      ' Declaration auslesen  
      s = ""
      If .CodeModule.CountOfDeclarationLines > 0 Then
        For iCount = 1 To .CodeModule.CountOfDeclarationLines
          If .CodeModule.Lines(iCount, 1) <> "" Then
            strProz = strProz & vbTab & vbTab & "Declaration" & vbTab & " (" & _
             .CodeModule.CountOfDeclarationLines & " Z.)" & vbCrLf
             s = "Declaration"
             s1 = "(" & .CodeModule.CountOfDeclarationLines & " Z.)"
            Exit For
          End If
        Next iCount
        If s <> "" Then
          tbl.Rows.Add
          tbl.Rows.Last.Cells.Split 1, 5, True
          With tbl.Rows.Last
            .Cells(1).Width = MillimetersToPoints(c1)
            .Cells(2).Width = MillimetersToPoints(c2)
            .Cells(3).Width = MillimetersToPoints(c3)
            .Cells(4).Width = MillimetersToPoints(c4)
            .Cells(5).Width = MillimetersToPoints(c5)
          End With
          tbl.Rows.Last.Cells(3).Range.Text = s
          tbl.Rows.Last.Cells(3).Range.Paragraphs.Alignment = wdAlignParagraphLeft
          tbl.Rows.Last.Range.Paragraphs.KeepWithNext = False
          tbl.Rows.Last.Cells(4).Range.Text = s1
        End If
      End If
      ' Prozeduren auslesen  
      strProc = "": iProz = 0: iFkt = 0: iSub = 0
      Dim iI As Integer
      For iCount = 1 To .CodeModule.CountOfLines
        If .CodeModule.ProcOfLine(iCount, vbext_pk_Proc) <> strProc Then
          strProc = .CodeModule.ProcOfLine(iCount, vbext_pk_Proc)
          strProc = .CodeModule.ProcOfLine(iCount, vbext_pk_Proc)
          iI = iCount
          If InStr(1, .CodeModule.Lines(iI, 1), "Sub ") > 0 Then
            iSub = iSub + 1: iCountSub = iCountSub + 1
            strProz = strProz & vbTab & vbTab & "Sub " & strProc & vbTab & " (" & _
             .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)" & vbCrLf
             s = "Sub " & strProc
             s1 = "(" & .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)"
          ElseIf InStr(1, .CodeModule.Lines(iI, 1), "Function ") > 0 Then
            iFkt = iFkt + 1: iCountFkt = iCountFkt + 1
            strProz = strProz & vbTab & vbTab & "Function " & strProc & vbTab & " (" & _
             .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)" & vbCrLf
              s = "Function " & strProc
              s1 = "(" & .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)"
          ElseIf InStr(1, .CodeModule.Lines(iI, 1), "Property ") > 0 Then
            strProz = strProz & vbTab & vbTab & "Property " & strProc & vbTab & " (" & _
             .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)" & vbCrLf
              s = "Property " & strProc
              s1 = "(" & .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)"
          End If
          Do While .CodeModule.Lines(iI, 1) = "" Or Left(Trim(.CodeModule.Lines(iI, 1)), 1) = "'"
            iI = iI + 1
            If InStr(1, .CodeModule.Lines(iI, 1), "Sub ") > 0 Then
              iSub = iSub + 1: iCountSub = iCountSub + 1
              strProz = strProz & vbTab & vbTab & "Sub " & strProc & vbTab & " (" & _
              .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)" & vbCrLf
              s = "Sub " & strProc
              s1 = "(" & .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)"
             Exit Do
            ElseIf InStr(1, .CodeModule.Lines(iI, 1), "Function ") > 0 Then
              iFkt = iFkt + 1: iCountFkt = iCountFkt + 1
              strProz = strProz & vbTab & vbTab & "Function " & strProc & vbTab & " (" & _
               .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)" & vbCrLf
              s = "Function " & strProc
              s1 = "(" & .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)"
              Exit Do
            ElseIf InStr(1, .CodeModule.Lines(iI, 1), "Property ") > 0 Then
              strProz = strProz & vbTab & vbTab & "Property " & strProc & vbTab & " (" & _
               .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)" & vbCrLf
              s = "Property " & strProc
              s1 = "(" & .CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)"
            End If
          Loop
          tbl.Rows.Add
          tbl.Rows.Last.Cells(3).Range.Text = s
          tbl.Rows.Last.Cells(3).Range.Paragraphs.Alignment = wdAlignParagraphLeft
          tbl.Rows.Last.Range.Paragraphs.KeepWithNext = False
          tbl.Rows.Last.Cells(4).Range.Text = s1

          iCountProz = iCountProz + 1
          iProz = iProz + 1
        End If
      Next iCount
      End With
    rw.Cells(rw.Cells.Count).Range.Text = "(" & iSub & "Sub | " & iFkt & "Fkt)"
    rw.Cells(2).Shading.BackgroundPatternColor = wdColorGray05
    rw.Cells(rw.Cells.Count).Shading.BackgroundPatternColor = wdColorGray05
    rw.Cells(rw.Cells.Count).Range.Paragraphs.Alignment = wdAlignParagraphRight
    If rw.Cells.Count = 5 Then
      rw.Cells(2).Merge MergeTo:=rw.Cells(4)
      rw.Cells(2).Range.Paragraphs.Alignment = wdAlignParagraphLeft
      rw.Range.Paragraphs.KeepWithNext = True
    Else
      rw.Cells(3).Range.Paragraphs.Alignment = wdAlignParagraphLeft
      rw.Cells(2).Range.Paragraphs.Alignment = wdAlignParagraphLeft
    End If
    tbl.Rows(1).Range.Text = myProject.Name & " (" & _
    strFile(UBound(strFile())) & ")" & vbTab & iCountProz & " Prozedur(en): " & iCountSub & " Sub | " & iCountFkt & " Fkt"
    tbl.Rows(1).Range.Font.Bold = True
    tbl.Rows(1).Shading.BackgroundPatternColor = wdColorGray15
    Next myComponent
    oDoc.Range.InsertAfter vbCrLf
  End If
End If
Application.ScreenRefresh
iCountSub = 0: iCountFkt = 0
Next myProject
System.Cursor = wdCursorNormal
End Sub