Aktuelle Seite:
/vba/vbalistmakronamen2.htm
Letzte Änderung: 10.08.2018

Getestet unter Word2000Getestet unter WordXPGetestet unter Word2003  
Beispiel anzeigen
Makro/Datei speichern
Print

Dieses Beispiel ist eine Erweiterung des Makros  modListMacros und zeigt eine alternative Darstellung aller Module und Prozeduren auf:
Die einzelnen Prozeduren werden in Tabellenform in einem neuen Dokument ausgegeben, wobei für jedes Modul (Klassenmodul,Modul,UserForm) die Anzahl der Sub- und Function-Prozeduren angezeigt werden.

Zur Ermittlung werden nacheinander alle Projekte (VBProjects-Einträge) durchlaufen. Diese entsprechen den obersten Einträgen im Projekt-Explorer der IDE und stellen alle geöffneten und geladenen Dokumente, Vorlagen und Add-Ins dar.
Sofern diese nicht geschützt sind, was für Add-Ins und per Kennwort geschützte Vorlagen und Dokumente gilt, werden in einer weiteren Schleife alle enthaltenen Module (VBComponents-Einträge) durchlaufen und der Typ des Moduls (Standardmodul/Userform/Klassenmodul/Dokument) ermittelt.
Die Ermittlung der in den Modulen enthaltenen Prozeduren lassen sich nicht so einfach in einer Schleife ermitteln, sondern das Modul muss zeilenweise durchlaufen werden, um den Namen der Prozedur, in der sich die jeweilige Zeile befindet, zu ermitteln. Dazu steht die ProcOfLine-Eigenschaft des CodeModule-Objekts der Module zur Verfügung.
Für jede Prozedur werden zusätzlich die Zeilenanzahl ausgelesen und mitgespeichert.

Der Deklarationsbereich, also der Bereich vor der ersten Prozedur, in der prozedurübergreifende Deklarationen oder Definitionen erfasst werden, kann direkt mit einer eigenen Methode erfasst werden. Dazu steht die CountOfDeclarationLines-Methode zur Verfügung, die die Gesamtzeilenzahl dieses Bereiches zurückliefert. Da aber auch Leerzeilen miterfasst werden, wird der Deklarationsbereich nur berücksichtigt, wenn er nicht nur aus Leerzeilen besteht.

Die so gesammelten Informationen werden abschließend in ein neues Dokument geschrieben.

Wichtig:
Damit auf die Projekte und Module zugegriffen werden kann, muss in der IDE ein Verweis (Extras/Verweise) auf die

Microsoft Visual Basic for Applications Extensibility 5.3

gesetzt sein!

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 


 www.chf-online.de/vba/vbalistmakronamen2.htm © 2001-11 Christian Freßdorf (Zaphod-Systems)