Alle Prozedur-/Makronamen tabellarisch auflisten |
|
Dieses Beispiel ist eine Erweiterung des Makros modListMacros und zeigt eine alternative Darstellung aller Module und Prozeduren auf:
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. 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: 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 |
Besucher: 0 online | 0 heute | 0 diesen Monat | 2202537 insgesamt | Seitenaufrufe: 63 | Letzte Änderung: 10.08.2018 | © 2001-18 Christian Freßdorf | ||||
Geh' nicht nur die glatten Straßen, geh' Wege, die noch niemand ging - damit Du Spuren hinterläßt und nicht nur Staub! |
powered by phpCMS and PAX |