VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.UserDocument VbTestDoc 
   ClientHeight    =   975
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2025
   HScrollSmallChange=   15
   ScaleHeight     =   975
   ScaleWidth      =   2025
   VScrollSmallChange=   15
   Begin VB.ComboBox ComboProjekt 
      Height          =   315
      Left            =   2280
      Style           =   2  'Dropdown-Liste
      TabIndex        =   5
      Top             =   120
      Width           =   2535
   End
   Begin VB.ComboBox ComboModul 
      Height          =   315
      Left            =   5520
      Style           =   2  'Dropdown-Liste
      TabIndex        =   4
      Top             =   120
      Width           =   2535
   End
   Begin VB.CommandButton C_Analyse 
      Caption         =   "Analyse"
      Height          =   285
      Left            =   120
      TabIndex        =   3
      Top             =   120
      Width           =   1455
   End
   Begin ComctlLib.ListView ListViewResult 
      Height          =   1335
      Index           =   1
      Left            =   240
      TabIndex        =   0
      Top             =   1080
      Width           =   1935
      _ExtentX        =   3413
      _ExtentY        =   2355
      View            =   3
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   327682
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin ComctlLib.ListView ListViewResult 
      Height          =   1575
      Index           =   2
      Left            =   240
      TabIndex        =   1
      Top             =   1080
      Width           =   2415
      _ExtentX        =   4260
      _ExtentY        =   2778
      View            =   3
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   327682
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin ComctlLib.ListView ListViewResult 
      Height          =   1935
      Index           =   3
      Left            =   240
      TabIndex        =   2
      Top             =   1080
      Width           =   2895
      _ExtentX        =   5106
      _ExtentY        =   3413
      View            =   3
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   327682
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin ComctlLib.TabStrip TabStrip1 
      Height          =   2775
      Left            =   120
      TabIndex        =   6
      Top             =   600
      Width           =   8295
      _ExtentX        =   14631
      _ExtentY        =   4895
      _Version        =   327682
      BeginProperty Tabs {0713E432-850A-101B-AFC0-4210102A8DA7} 
         NumTabs         =   3
         BeginProperty Tab1 {0713F341-850A-101B-AFC0-4210102A8DA7} 
            Caption         =   "Prozeduren"
            Key             =   ""
            Object.Tag             =   ""
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab2 {0713F341-850A-101B-AFC0-4210102A8DA7} 
            Caption         =   "Ø Prozeduren"
            Key             =   ""
            Object.Tag             =   ""
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab3 {0713F341-850A-101B-AFC0-4210102A8DA7} 
            Caption         =   "Module"
            Key             =   ""
            Object.Tag             =   ""
            ImageVarType    =   2
         EndProperty
      EndProperty
   End
   Begin VB.Label Label1 
      Caption         =   "Projekt:"
      Height          =   255
      Left            =   1680
      TabIndex        =   8
      Top             =   180
      Width           =   615
   End
   Begin VB.Label Label2 
      Caption         =   "Modul:"
      Height          =   255
      Left            =   4920
      TabIndex        =   7
      Top             =   180
      Width           =   615
   End
End
Attribute VB_Name = "VbTestDoc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

Public WithEvents mVBProjectsEvents As VBProjects
Attribute mVBProjectsEvents.VB_VarHelpID = -1
Public WithEvents mVBComponentsEvents As VBComponents
Attribute mVBComponentsEvents.VB_VarHelpID = -1
Private VBInstance As VBIDE.VBE
Private Connect As Connect

Private Type ProcMetricsType
   Parameters As Long
   McCabe As Long
   Statements As Long
   TotalLines As Long
   LinesOfCode As Long
   CommentCodes As Long
   EmptyLines As Long
   MaxLineLength As Long
   Indent As Long
   FanOut As Long
   VarReferenced(1 To 3) As Long
   VarSet(1 To 3) As Long
End Type

Private Type SumMinMax
   Sum As Long
   Min As Long
   max As Long
End Type

Private Type ModuleMetricsType
   Parameters As SumMinMax
   McCabe As SumMinMax
   Statements As SumMinMax
   LinesOfCode As SumMinMax
   LinesOfDelareCode As Long
   CommentCodes As SumMinMax
   EmptyLines As SumMinMax
   MaxLineLength As Long
   Indent As SumMinMax
   ProcCount As Long
   GlobalVar(0 To 1) As Long
   Constant(0 To 1) As Long
   proc(0 To 1) As Long
End Type

Private ProcMetrics As ProcMetricsType
Private ModuleMetrics As ModuleMetricsType
Private ProgramMetrics As ModuleMetricsType

Private ProcNamesCollection As New Collection
Private PublicName%, PrivatName1%, PrivatName2%

Private VarNamesCollection As New Collection
Private PublicVar%, PrivatVar1%, PrivatVar2%, PrivatVar3%

Private ModuleFanInOut() As Integer

Private Declare Sub LockWindowUpdate Lib "user32" (ByVal hwndLock As Long)

'Startet die Analyse
Private Sub C_Analyse_Click()

frmAnalyse.Left = Screen.Width / 2 - frmAnalyse.Width / 2
frmAnalyse.Top = Screen.Height / 2 - frmAnalyse.Height / 2
frmAnalyse.Show 0, Me
canceled% = False
Set formAddIn = Me

Dim code As CodeModule
Dim project As VBProject
Dim proc As ProcNamesType

If C_Analyse.Enabled = False Then Exit Sub
Set project = VBInstance.VBProjects(ComboProjekt.ListIndex + 1)
C_Analyse.Enabled = False
LockWindowUpdate UserDocument.hwnd

Init True
Do While ProcNamesCollection.Count: ProcNamesCollection.Remove 1: Loop
Do While VarNamesCollection.Count: VarNamesCollection.Remove 1: Loop
ReDim ModuleFanInOut(1 To project.VBComponents.Count, 1 To project.VBComponents.Count)

'Schritt 1: vorbereiten...
frmAnalyse.LabelProgressBar1.Caption = "Schritt 1 von 2"
frmAnalyse.ProgressBar1.value = 0: frmAnalyse.Refresh
frmAnalyse.ProgressBar1.max = project.VBComponents.Count
For n% = 1 To project.VBComponents.Count
   z& = z& + ProcModuleCount(project.VBComponents(n%), n%, ComboModul.ListIndex = 0 Or ComboModul.ListIndex = n%)
   frmAnalyse.ProgressBar1.value = n%
   If canceled% Then Init False: GoTo ende
Next
PublicName% = ProcNamesCollection.Count
PublicVar% = VarNamesCollection.Count

'Schritt 2: nun wirklich analysieren...
frmAnalyse.LabelProgressBar1.Caption = "Schritt 2 von 2"
frmAnalyse.ProgressBar1.value = 0: frmAnalyse.Refresh
If z& Then frmAnalyse.ProgressBar1.max = z&
Metrics_Clear ProgramMetrics
If ComboModul.ListIndex = 0 Then
   For n% = 1 To project.VBComponents.Count
      Analyse_Module project.VBComponents(n%), n%
      If canceled% Then Init False: GoTo ende
   Next
Else
   Analyse_Module project.VBComponents(ComboModul.ListIndex), ComboModul.ListIndex
End If
If canceled% Then Init False: GoTo ende

'FanIn,FanOut der Module eintragen
For n% = 1 To project.VBComponents.Count
   FanOut% = 0: For i% = 1 To project.VBComponents.Count: FanOut% = FanOut% + IIf(ModuleFanInOut(n%, i%) > 0, 1, 0): Next
   FanIn% = 0: For i% = 1 To project.VBComponents.Count: FanIn% = FanIn% + IIf(ModuleFanInOut(i%, n%) > 0, 1, 0): Next
   ListView_SetValue ListViewResult(3), project.VBComponents(n%).Name, "*", "FanIn", IIf(ComboModul.ListIndex = 0, "" & FanIn%, "???")
   ListView_SetValue ListViewResult(3), project.VBComponents(n%).Name, "*", "FanOut", "" & FanOut%
Next
'FanIn der Prozeduren eintragen
For n = 1 To ProcNamesCollection.Count
   Set proc = ProcNamesCollection(n%)
   ListView_SetValue ListViewResult(1), project.VBComponents(proc.Module).Name, proc.Name, "FanIn", "" & proc.used
Next
'(gesamt) eintragen
If ProgramMetrics.ProcCount > 0 And ListViewResult(2).ListItems.Count > 1 Then
   ListView_AddItem ListViewResult(2), "(gesamt)" + Chr$(9) + Metrics_Format2(ProgramMetrics)
End If
If ProgramMetrics.ProcCount > 0 And ListViewResult(3).ListItems.Count > 1 Then
   ListView_AddItem ListViewResult(3), "(gesamt)" + Chr$(9) + Metrics_Format3(ProgramMetrics)
End If

ende:
LockWindowUpdate 0
If TabStrip1.SelectedItem.Index > 1 Then Set TabStrip1.SelectedItem = TabStrip1.Tabs(1)
C_Analyse.Enabled = True
Unload frmAnalyse

End Sub

'Analysiert ein Modul
Sub Analyse_Module(comp As VBComponent, currentmodule%)

Dim memb As Member
Dim ProcName As ProcNamesType

PrivatName1% = ProcNamesCollection.Count + 1: PrivatName2% = ProcNamesCollection.Count
PrivatVar1% = VarNamesCollection.Count + 1: PrivatVar2% = VarNamesCollection.Count
If comp.Type <> vbext_ct_ResFile And comp.Type <> vbext_ct_RelatedDocument Then
   For Each memb In comp.CodeModule.Members
      If (memb.Type = vbext_mt_Method Or memb.Type = vbext_mt_Property) And memb.Scope = vbext_Private And memb.CodeLocation > comp.CodeModule.CountOfDeclarationLines Then
         Set ProcName = New ProcNamesType
         ProcName.Name = LCase$(memb.Name)
         ProcName.Module = currentmodule%
         ProcName.used = 0
         ProcNamesCollection.Add ProcName
         PrivatName2% = PrivatName2% + 1
      ElseIf (memb.Type = vbext_mt_Const Or memb.Type = vbext_mt_Variable) And (memb.Scope = vbext_Private Or comp.Type <> vbext_ct_StdModule) Then
         Set ProcName = New ProcNamesType
         ProcName.Name = LCase$(memb.Name)
         ProcName.Module = currentmodule%
         ProcName.used = 0
         VarNamesCollection.Add ProcName
         PrivatVar2% = PrivatVar2% + 1
      End If
   Next

   Metrics_Clear ModuleMetrics
   
   For linenr% = 1 To comp.CodeModule.CountOfDeclarationLines
      zeile$ = Trim$(vor$ + comp.CodeModule.Lines(linenr%, 1))
      commentPos% = InStr_Ex(1, zeile$, "'")
      If commentPos% Then zeile$ = Trim$(Left$(zeile$, commentPos% - 1))
      If Len(zeile$) > 0 Then ModuleMetrics.LinesOfDelareCode = ModuleMetrics.LinesOfDelareCode + 1
   Next

   For Each memb In comp.CodeModule.Members
      i% = IIf(memb.Scope = vbext_Private, 0, 1)
      Select Case memb.Type
      Case vbext_mt_Variable
         ModuleMetrics.GlobalVar(i%) = ModuleMetrics.GlobalVar(i%) + 1
      Case vbext_mt_Const
         ModuleMetrics.Constant(i%) = ModuleMetrics.Constant(i%) + 1
      Case vbext_mt_Method
         If memb.CodeLocation > comp.CodeModule.CountOfDeclarationLines Then
            Analyse_Proc comp, currentmodule%, memb.Name, vbext_pk_Proc, i%
         End If
      Case vbext_mt_Event
         '...todo
      Case vbext_mt_Property
         Analyse_Proc comp, currentmodule%, memb.Name, vbext_pk_Get, i%
         Analyse_Proc comp, currentmodule%, memb.Name, vbext_pk_Let, i%
         Analyse_Proc comp, currentmodule%, memb.Name, vbext_pk_Set, i%
      End Select
      DoEvents
      If canceled% Then Exit For
   Next
End If

If ModuleMetrics.ProcCount Then
   ListView_AddItem ListViewResult(2), comp.Name & Chr$(9) & Metrics_Format2(ModuleMetrics)
End If
ListView_AddItem ListViewResult(3), comp.Name & Chr$(9) & Metrics_Format3(ModuleMetrics)
Metrics_AddModule ProgramMetrics, ModuleMetrics

End Sub

'Analysiert eine Sub/Function
Sub Analyse_Proc(comp As VBComponent, currentmodule%, PName$, ByVal typ%, ByVal i%)
Dim ProcName As ProcNamesType

If Not isExisting%(comp, PName$, typ%) Then Exit Sub

countlinenr% = comp.CodeModule.ProcCountLines(PName$, typ%)
ModuleMetrics.proc(i%) = ModuleMetrics.proc(i%) + 1

startlinenr% = comp.CodeModule.ProcStartLine(PName$, typ%)
allcommands$ = ""

ProcMetrics.McCabe = 1            'McCabe-Wert
ProcMetrics.LinesOfCode = 0       'Anzahl Code-Zeilen (ohne Leerzeilen und reinen Kommentarzeilen)
ProcMetrics.TotalLines = 0        'Anzahl Zeilen gesamt
ProcMetrics.Statements = 0        'Anzahl der Befehle
ProcMetrics.CommentCodes = 0      'Anzahl Kommentar-Zeilen (auch "befehl 'kommentar")
ProcMetrics.EmptyLines = 0        'Anzahl leere Zeilen
ProcMetrics.Parameters = 0        'Anzahl der Function/Sub-Parameter
ProcMetrics.FanOut = 0            'Anzahl der aufgerufenen Prozeduren
ProcMetrics.MaxLineLength = 0     'Größte Zeilenlänge
ProcMetrics.Indent = 0            'Größte Einrücktiefe
ProcMetrics.VarReferenced(1) = 0  'Anzahl der referenzierten globalen Variablen
ProcMetrics.VarReferenced(2) = 0  'Anzahl der referenzierten privaten Variablen
ProcMetrics.VarReferenced(3) = 0  'Anzahl der referenzierten Parameter
ProcMetrics.VarSet(1) = 0         'Anzahl der veränderten globalen Variablen
ProcMetrics.VarSet(2) = 0         'Anzahl der veränderten privaten Variablen
ProcMetrics.VarSet(3) = 0         'Anzahl der veränderten Parameter
PrivatVar3% = PrivatVar2%

vor$ = "": Indent% = 0: isDeklaration% = True
For linenr% = startlinenr% To startlinenr% + countlinenr% - 1
   zeile$ = RTrim$(comp.CodeModule.Lines(linenr%, 1))
   If Len(zeile$) > ProcMetrics.MaxLineLength Then ProcMetrics.MaxLineLength = Len(zeile$)
   zeile$ = Trim$(vor$ + zeile$)
   
   'Zähler Zeilen/Leerzeilen/Kommentarzeilen
   ProcMetrics.TotalLines = ProcMetrics.TotalLines + 1
   If Len(zeile$) = 0 Then ProcMetrics.EmptyLines = ProcMetrics.EmptyLines + 1
   commentPos% = InStr_Ex(1, zeile$, "'")
   If commentPos% Then zeile$ = Trim$(Left$(zeile$, commentPos% - 1)): ProcMetrics.CommentCodes = ProcMetrics.CommentCodes + 1
   If Len(zeile$) > 0 Then ProcMetrics.LinesOfCode = ProcMetrics.LinesOfCode + 1
   If Right$(zeile$, 1) = "_" Then vor$ = Left$(zeile$, Len(zeile$) - 1): zeile$ = "" Else vor$ = ""
   
   If isDeklaration% = True And Len(zeile$) > 0 Then
      isDeklaration% = False
      If InStr(parse$(zeile$, "("), "Function ") Then ProcMetrics.VarSet(3) = 1 'Return-Wert
      i% = 0: ab% = 1
      If zeile$ <> vbNullString Then
         Do
            i% = InStr(i% + 1, zeile$, "(")
            If i% = 0 Then par$ = Trim$(Left$(zeile$, InStr(ab%, zeile$, ")") - 1)) Else ab% = InStr(i% + 1, zeile$, ")") + 1
         Loop While i%
      End If
      Do While Len(par$)
         ProcMetrics.Parameters = ProcMetrics.Parameters + 1
         Set ProcName = New ProcNamesType
         ProcName.Name = LCase$(RemoveTypeEtc$(parse$(par$, ","), isByVal%)): par$ = Trim$(par$)
         ProcName.isByVal = isByVal%
         ProcName.used = 0
         VarNamesCollection.Add ProcName
         PrivatVar3% = PrivatVar3% + 1
      Loop
   Else
      allcommands$ = allcommands$ + ":" + zeile$
      ersetze zeile$, "Then ", "Then: "
      ersetze zeile$, "Else ", "Else: "
      IndentLine% = 0
      Do While Len(zeile$)
         i% = InStr_Ex(1, zeile$, ":")
         If i% = 0 Then cmd$ = Trim$(zeile$): zeile$ = "" Else cmd$ = Trim$(Left$(zeile$, i% - 1)): zeile$ = Trim$(Mid$(zeile$, i% + 1))
         
         '---Befehls-Metriken---
         bef$ = parse$(cmd$, " "): cmd$ = Trim$(cmd$)
         If Len(bef$) > 0 And (bef$ <> "End" Or cmd$ = "") And bef$ <> "Loop" And bef$ <> "Next" And bef$ <> "Wend" Then
            ProcMetrics.Statements = ProcMetrics.Statements + 1
         End If
         
         'If,ElseIf,Else,EndIf
         If bef$ = "If" Then
            ProcMetrics.McCabe = ProcMetrics.McCabe + 1
            Indent% = Indent% + 1
            If Len(zeile$) Then IndentLine% = IndentLine% + 1
         ElseIf bef$ = "ElseIf" Then
            ProcMetrics.McCabe = ProcMetrics.McCabe + 1
         ElseIf bef$ = "End" And Left(cmd$, 2) = "If" Then
            Indent% = Indent% - 1
         'Do,Loop,While,Wend
         ElseIf bef$ = "Do" Or bef$ = "While" Then
            ProcMetrics.McCabe = ProcMetrics.McCabe + 1
            Indent% = Indent% + 1
         ElseIf bef$ = "Loop" Or bef$ = "Wend" Then
            Indent% = Indent% - 1
         'SelectCase,Case,CaseElse,EndSelect
         ElseIf bef$ = "Select" And Left$(cmd$, 4) = "Case" Then
            Indent% = Indent% + 1
            '***fügen Sie folgende Zeile hinzu, um den alternativen McCabe zu aktivieren***
            'ProcMetrics.McCabe = ProcMetrics.McCabe + 1
         ElseIf bef$ = "Case" Then
            '***entfernen Sie folgende Zeile hinzu, um den alternativen McCabe zu aktivieren***
            If Left$(cmd$, 4) <> "Else" Then ProcMetrics.McCabe = ProcMetrics.McCabe + 1
         ElseIf bef$ = "End" And Left$(cmd$, 6) = "Select" Then
            Indent% = Indent% - 1
         'For,Next
         ElseIf bef$ = "For" Then
            ProcMetrics.McCabe = ProcMetrics.McCabe + 1
            Indent% = Indent% + 1
         ElseIf bef$ = "Next" Then
            Indent% = Indent% - 1
         End If
         If Indent% > ProcMetrics.Indent Then ProcMetrics.Indent = Indent%
      Loop
      Indent% = Indent% - IndentLine%
      If (linenr% Mod 10) = 0 Then DoEvents: If canceled% Then Exit For
   End If
Next
'If Indent% <> 0 And canceled% = False Then MsgBox Str$(Indent%), , "Fehler bei Indent-Berechnung: " + PName$

allcommands$ = LCase$(allcommands$)
For n% = PrivatName1% To PrivatName2%: UpdateFanInOutProc allcommands$, PName$, currentmodule%, n%: Next
For n% = 1 To PublicName%: UpdateFanInOutProc allcommands$, PName$, currentmodule%, n%: Next

For n% = 1 To PublicVar%: UpdateFanInOutVar allcommands$, currentmodule%, n%, 1: Next
For n% = PrivatVar1% To PrivatVar2%: UpdateFanInOutVar allcommands$, currentmodule%, n%, 2: Next
For n% = PrivatVar2% + 1 To PrivatVar3%: UpdateFanInOutVar allcommands$, currentmodule%, n%, 3: Next
Do While VarNamesCollection.Count > PrivatVar2%: VarNamesCollection.Remove PrivatVar2% + 1: Loop

'Dim proc As ProcNamesType
'Set proc = FindProcNamesType(currentmodule%, LCase$(PName$))
'If Not proc Is Nothing Then
'   proc.VarRef = ProcMetrics.VarReferenced(1) + ProcMetrics.VarReferenced(2) + ProcMetrics.VarReferenced(3)
'   proc.VarSet = ProcMetrics.VarSet(1) + ProcMetrics.VarSet(2) + ProcMetrics.VarSet(3)
'   proc.FanOut = ProcMetrics.FanOut
'End If

procVarRef% = ProcMetrics.VarReferenced(1) + ProcMetrics.VarReferenced(2) + ProcMetrics.VarReferenced(3)
procVarSet% = ProcMetrics.VarSet(1) + ProcMetrics.VarSet(2) + ProcMetrics.VarSet(3)
infoflow% = procVarRef% * procVarSet%

ext$ = ""
If typ% = vbext_pk_Get Then ext$ = "(Get)"
If typ% = vbext_pk_Let Then ext$ = "(Let)"
If typ% = vbext_pk_Set Then ext$ = "(Set)"

ListView_AddItem(ListViewResult(1), comp.Name + Chr$(9) + PName$ + ext$ + Chr$(9) & ProcMetrics.Parameters & Chr$(9) & ProcMetrics.McCabe & Chr$(9) & ProcMetrics.Indent & Chr$(9) & ProcMetrics.LinesOfCode & Chr$(9) & ProcMetrics.Statements & Chr$(9) & Int(100 * ProcMetrics.CommentCodes / ProcMetrics.TotalLines + 0.5) & "%" & Chr$(9) & Int(100 * ProcMetrics.EmptyLines / ProcMetrics.TotalLines + 0.5) & "%" & Chr$(9) & ProcMetrics.MaxLineLength & Chr$(9) & Chr$(9) & ProcMetrics.FanOut & Chr$(9) & infoflow%).Tag = Str$(comp.CodeModule.ProcBodyLine(PName$, typ%))
Metrics_AddProc ModuleMetrics, ProcMetrics
If frmAnalyse.ProgressBar1.value < frmAnalyse.ProgressBar1.max Then frmAnalyse.ProgressBar1.value = frmAnalyse.ProgressBar1.value + 1

End Sub

Private Sub UpdateFanInOutProc(allcommands$, ProcName$, currentmodule%, n%)

Dim proc As ProcNamesType
Set proc = ProcNamesCollection(n%)
If LCase$(ProcName$) = proc.Name Then Exit Sub

i% = 0
Do
   i% = InStr_Word(i% + 1, allcommands$, proc.Name): If i% = 0 Then Exit Do
   proc.used = proc.used + 1
   ProcMetrics.FanOut = ProcMetrics.FanOut + 1
   If proc.Module > 0 And proc.Module <> currentmodule% Then ModuleFanInOut(currentmodule%, proc.Module) = ModuleFanInOut(currentmodule%, proc.Module) + 1
Loop

End Sub

Private Sub UpdateFanInOutVar(allcommands$, currentmodule%, n%, globalstate%)
'globalstate%: 1=global 2=private 3=parameter

Dim proc As ProcNamesType
Set proc = VarNamesCollection(n%)

i% = 0: varrefflag% = False: varsetflag% = proc.isByVal = True And globalstate% = 3
Do
   i% = InStr_Word(i% + 1, allcommands$, proc.Name): If i% = 0 Then Exit Do
   If isAssign%(allcommands$, i% - 1, i% + Len(proc.Name)) Then
      If Not varsetflag% Then varsetflag% = True: ProcMetrics.VarSet(globalstate%) = ProcMetrics.VarSet(globalstate%) + 1
   Else
      If Not varrefflag% Then varrefflag% = True: ProcMetrics.VarReferenced(globalstate%) = ProcMetrics.VarReferenced(globalstate%) + 1
   End If
   If globalstate% = 1 And proc.Module > 0 And proc.Module <> currentmodule% Then ModuleFanInOut(currentmodule%, proc.Module) = ModuleFanInOut(currentmodule%, proc.Module) + 1
Loop While globalstate% = 1 Or varrefflag% = False Or varsetflag% = False

End Sub

Private Function isAssign%(allcommands$, pos1%, pos2%)

For n% = pos2% To Len(allcommands$)
   i% = InStr("= %&$@!#", Mid$(allcommands$, n%, 1))
   If i% = 1 Then Exit For
   If i% = 0 Then isAssign% = False: Exit Function
Next

For n% = pos1% To 1 Step -1
   i% = InStr(": %&$@!#", Mid$(allcommands$, n%, 1))
   If i% = 1 Then Exit For
   If i% = 0 Then isAssign% = False: Exit Function
Next

isAssign% = True

End Function

Private Function ProcModuleCount(comp As VBComponent, Index%, countflag%) As Long

Dim memb As Member

z& = 0
If comp.Type <> vbext_ct_ResFile And comp.Type <> vbext_ct_RelatedDocument Then
   For Each memb In comp.CodeModule.Members
      If (memb.Type = vbext_mt_Method Or memb.Type = vbext_mt_Property) And memb.CodeLocation > comp.CodeModule.CountOfDeclarationLines Then
         If countflag% Then
            If memb.Type = vbext_mt_Method Then
               z& = z& + 1
            Else
               If isExisting%(comp, memb.Name, vbext_pk_Get) Then z& = z& + 1
               If isExisting%(comp, memb.Name, vbext_pk_Let) Then z& = z& + 1
               If isExisting%(comp, memb.Name, vbext_pk_Set) Then z& = z& + 1
            End If
         End If
         If memb.Scope <> vbext_Private Then
            Set ProcName = New ProcNamesType
            ProcName.Name = LCase$(memb.Name)
            ProcName.Module = Index%
            ProcName.used = 0
            ProcNamesCollection.Add ProcName
         End If
      ElseIf memb.Type = vbext_mt_Variable Or memb.Type = vbext_mt_Const Then
         If memb.Scope <> vbext_Private And comp.Type = vbext_ct_StdModule Then
            Set ProcName = New ProcNamesType
            ProcName.Name = LCase$(memb.Name)
            ProcName.Module = Index%
            ProcName.used = 0
            VarNamesCollection.Add ProcName
         End If
      End If
      DoEvents
      If canceled% Then Exit For
   Next
End If
ProcModuleCount = z&

End Function

Private Sub Metrics_Clear(Metrics As ModuleMetricsType)

Metrics.ProcCount = 0
Metrics.Parameters.Sum = 0
Metrics.McCabe.Sum = 0
Metrics.LinesOfCode.Sum = 0
Metrics.LinesOfDelareCode = 0
Metrics.Statements.Sum = 0
Metrics.CommentCodes.Sum = 0
Metrics.EmptyLines.Sum = 0
Metrics.Indent.Sum = 0
Metrics.MaxLineLength = 0
Metrics.GlobalVar(1) = 0
Metrics.GlobalVar(0) = 0
Metrics.Constant(1) = 0
Metrics.Constant(0) = 0
Metrics.proc(1) = 0
Metrics.proc(0) = 0

End Sub

Private Function Metrics_Format2(Metrics As ModuleMetricsType) As String

a$ = Trim$(Str$(Int(10 * Metrics.Parameters.Sum / Metrics.ProcCount + 0.5) / 10)) & " {" & Metrics.Parameters.Min & "..." & Metrics.Parameters.max & "}"
a$ = a$ & Chr$(9) & Trim$(Str$(Int(10 * Metrics.McCabe.Sum / Metrics.ProcCount + 0.5) / 10)) & " {" & Metrics.McCabe.Min & "..." & Metrics.McCabe.max & "}"
a$ = a$ & Chr$(9) & Trim$(Str$(Int(10 * Metrics.Indent.Sum / Metrics.ProcCount + 0.5) / 10)) & " {" & Metrics.Indent.Min & "..." & Metrics.Indent.max & "}"
a$ = a$ & Chr$(9) & Trim$(Str$(Int(10 * Metrics.LinesOfCode.Sum / Metrics.ProcCount + 0.5) / 10)) & " {" & Metrics.LinesOfCode.Min & "..." & Metrics.LinesOfCode.max & "}"
a$ = a$ & Chr$(9) & Trim$(Str$(Int(10 * Metrics.Statements.Sum / Metrics.ProcCount + 0.5) / 10)) & " {" & Metrics.Statements.Min & "..." & Metrics.Statements.max & "}"
a$ = a$ & Chr$(9) & Int(Metrics.CommentCodes.Sum / Metrics.ProcCount + 0.5) & "% {" & Metrics.CommentCodes.Min & "%..." & Metrics.CommentCodes.max & "%}"
a$ = a$ & Chr$(9) & Int(Metrics.EmptyLines.Sum / Metrics.ProcCount + 0.5) & "% {" & Metrics.EmptyLines.Min & "%..." & Metrics.EmptyLines.max & "%}"
a$ = a$ & Chr$(9) & Metrics.MaxLineLength
Metrics_Format2 = a$

End Function

Private Function Metrics_Format3(Metrics As ModuleMetricsType) As String

a$ = "" & (Metrics.LinesOfCode.Sum + Metrics.LinesOfDelareCode)
a$ = a$ & Chr$(9) & Metrics.Statements.Sum
a$ = a$ & Chr$(9) & Metrics.GlobalVar(1) & " (+" & Metrics.GlobalVar(0) & ")"
a$ = a$ & Chr$(9) & Metrics.Constant(1) & " (+" & Metrics.Constant(0) & ")"
a$ = a$ & Chr$(9) & Metrics.proc(1) & " (+" & Metrics.proc(0) & ")"
Metrics_Format3 = a$

End Function

Private Sub Metrics_AddModule(M As ModuleMetricsType, MAdd As ModuleMetricsType)

Metrics_UpdateSumMinMax1 M.Parameters, MAdd.Parameters, M.ProcCount
Metrics_UpdateSumMinMax1 M.McCabe, MAdd.McCabe, M.ProcCount
Metrics_UpdateSumMinMax1 M.LinesOfCode, MAdd.LinesOfCode, M.ProcCount
Metrics_UpdateSumMinMax1 M.Statements, MAdd.Statements, M.ProcCount
Metrics_UpdateSumMinMax1 M.CommentCodes, MAdd.CommentCodes, M.ProcCount
Metrics_UpdateSumMinMax1 M.EmptyLines, MAdd.EmptyLines, M.ProcCount
Metrics_UpdateSumMinMax1 M.Indent, MAdd.Indent, M.ProcCount

M.LinesOfDelareCode = M.LinesOfDelareCode + MAdd.LinesOfDelareCode
If M.MaxLineLength < MAdd.MaxLineLength Then M.MaxLineLength = MAdd.MaxLineLength

M.GlobalVar(1) = M.GlobalVar(1) + MAdd.GlobalVar(1)
M.GlobalVar(0) = M.GlobalVar(0) + MAdd.GlobalVar(0)
M.Constant(1) = M.Constant(1) + MAdd.Constant(1)
M.Constant(0) = M.Constant(0) + MAdd.Constant(0)
M.proc(1) = M.proc(1) + MAdd.proc(1)
M.proc(0) = M.proc(0) + MAdd.proc(0)

M.ProcCount = M.ProcCount + MAdd.ProcCount

End Sub

Private Sub Metrics_AddProc(M As ModuleMetricsType, PAdd As ProcMetricsType)

If PAdd.TotalLines Then cl& = Int(100 * PAdd.CommentCodes / PAdd.TotalLines + 0.5) Else cl& = 0
If PAdd.TotalLines Then el& = Int(100 * PAdd.EmptyLines / PAdd.TotalLines + 0.5) Else el& = 0

Metrics_UpdateSumMinMax2 M.Parameters, PAdd.Parameters, M.ProcCount
Metrics_UpdateSumMinMax2 M.McCabe, PAdd.McCabe, M.ProcCount
Metrics_UpdateSumMinMax2 M.Statements, PAdd.Statements, M.ProcCount
Metrics_UpdateSumMinMax2 M.LinesOfCode, PAdd.LinesOfCode, M.ProcCount
Metrics_UpdateSumMinMax2 M.Indent, PAdd.Indent, M.ProcCount
Metrics_UpdateSumMinMax2 M.CommentCodes, cl&, M.ProcCount
Metrics_UpdateSumMinMax2 M.EmptyLines, el&, M.ProcCount

If M.MaxLineLength < PAdd.MaxLineLength Then M.MaxLineLength = PAdd.MaxLineLength
M.ProcCount = M.ProcCount + 1

End Sub

Private Sub Metrics_UpdateSumMinMax1(S As SumMinMax, SAdd As SumMinMax, z&)

S.Sum = S.Sum + SAdd.Sum
If z& = 0 Then
   S.Min = SAdd.Min
   S.max = SAdd.max
Else
   If SAdd.Min < S.Min Then S.Min = SAdd.Min
   If SAdd.max > S.max Then S.max = SAdd.max
End If

End Sub

Private Sub Metrics_UpdateSumMinMax2(S As SumMinMax, VAdd As Long, z&)

S.Sum = S.Sum + VAdd
If z& = 0 Then
   S.Min = VAdd
   S.max = VAdd
Else
   If VAdd < S.Min Then S.Min = VAdd
   If VAdd > S.max Then S.max = VAdd
End If

End Sub

Private Sub ComboProjekt_Click()
If ComboProjekt.ListIndex = -1 Then Exit Sub
Set mVBComponentsEvents = VBInstance.VBProjects(ComboProjekt.ListIndex + 1).VBComponents
ComboModul.Clear
ComboModul.AddItem "(alle Module)"
For Each comp In VBInstance.VBProjects(ComboProjekt.ListIndex + 1).VBComponents
   ComboModul.AddItem comp.Name
Next
ComboModul.ListIndex = 0
End Sub

Sub setze_projekte()
ComboProjekt.Clear
ComboModul.Clear
For Each proj In VBInstance.VBProjects
   ComboProjekt.AddItem proj.Name
Next
C_Analyse.Enabled = ComboProjekt.ListCount > 0
If ComboProjekt.ListCount > 0 Then ComboProjekt.ListIndex = 0
End Sub

Sub Init(b%)
For n% = 1 To TabStrip1.Tabs.Count
   ListViewResult(n%).Enabled = b%
   ListViewResult(n%).ListItems.Clear
Next
End Sub

Private Sub ListViewResult_ColumnClick(Index As Integer, ByVal ColumnHeader As ComctlLib.ColumnHeader)
ListView_Sort ListViewResult(Index), ColumnHeader
End Sub

Private Sub ListViewResult_DblClick(Index As Integer)
If Index = 1 Then
   showcode ListViewResult(Index).SelectedItem
ElseIf Index = 3 Then
   Screen.MousePointer = 11
   Dim project As VBProject
   Set project = VBInstance.VBProjects(ComboProjekt.ListIndex + 1)
   For n% = 1 To project.VBComponents.Count
      If project.VBComponents(n%).Name = ListViewResult(Index).SelectedItem.Text Then
         FanOut$ = "": For i% = 1 To project.VBComponents.Count: FanOut$ = FanOut$ & IIf(ModuleFanInOut(n%, i%) > 0, ", " & ModuleFanInOut(n%, i%) & " * " & project.VBComponents(i%).Name, ""): Next
         FanOut$ = Mid$(FanOut$, 3): If FanOut$ = "" Then FanOut$ = "-"
         FanIn$ = "": For i% = 1 To project.VBComponents.Count: FanIn$ = FanIn$ & IIf(ModuleFanInOut(i%, n%) > 0, ", " & ModuleFanInOut(i%, n%) & " * " & project.VBComponents(i%).Name, ""): Next
         FanIn$ = Mid$(FanIn$, 3): If FanIn$ = "" Then FanIn$ = "-"
         Screen.MousePointer = 0
         MsgBox "FanOut:" + vbLf + FanOut$ + vbLf + vbLf + "FanIn:" + vbLf + FanIn$, , ListViewResult(Index).SelectedItem.Text
         Exit For
      End If
   Next
   Screen.MousePointer = 0
End If
End Sub

Sub showcode(itm As ListItem)

Dim comp As VBComponent

If itm Is Nothing Then Exit Sub
linenr% = Val(itm.Tag): If linenr% = 0 Then Exit Sub
Dim project As VBProject
Set project = VBInstance.VBProjects(ComboProjekt.ListIndex + 1)
For Each comp In project.VBComponents
   If comp.Name = itm.Text Then
      comp.CodeModule.CodePane.SetSelection linenr%, 1, linenr%, 1
      comp.CodeModule.CodePane.TopLine = linenr%
      comp.CodeModule.CodePane.Show
      comp.CodeModule.CodePane.Window.SetFocus
      Exit For
   End If
Next

End Sub

Private Sub TabStrip1_Click()
For n% = 1 To TabStrip1.Tabs.Count
   ListViewResult(n%).Visible = TabStrip1.SelectedItem.Index = n%
Next
End Sub
   
Function RemoveTypeEtc$(p$, isByVal%)

p$ = Trim$(p$): isByVal% = False
If Left$(p$, 9) = "Optional " Then p$ = Trim$(Mid$(p$, 10))
If Left$(p$, 6) = "ByVal " Then p$ = Trim$(Mid$(p$, 7)): isByVal% = True
If Left$(p$, 6) = "ByRef " Then p$ = Trim$(Mid$(p$, 7))
p$ = Trim$(parse$((p$), "As")): p$ = Trim$(parse$((p$), "=")): p$ = Trim$(parse$((p$), "("))
If InStr("%&$@!#", Right$(p$, 1)) > 0 And Len(p$) > 0 Then p$ = Left$(p$, Len(p$) - 1)
RemoveTypeEtc$ = p$

End Function
         
Private Sub UserDocument_Initialize()
ListView_SetzeKopf ListViewResult(1), "Modul,1000,Proc,2000,Par,600R,McCabe,600R,Indent,600R,LOC,600R,Stmts,600R,Comment,600R,Empty,600R,LineLen,600R,FanIn,600R,FanOut,600R,InfoFlow,600R"
ListView_SetzeKopf ListViewResult(2), "Modul,1000,Par,1000R,McCabe,1000R,Indent,1000R,LOC,1000R,Statements,1000R,Comment,1000R,Empty,1000R,LineLen,1000R"
ListView_SetzeKopf ListViewResult(3), "Modul,1000,LOC,600R,Stmts,600R,Glob.Var,600R,Const,600R,Proc,600R,FanIn,600R,FanOut,600R"
End Sub

Private Sub UserDocument_Resize()

If UserDocument.ScaleWidth - 240 > 0 Then TabStrip1.Width = UserDocument.ScaleWidth - 240
If UserDocument.ScaleHeight - TabStrip1.Top - 120 > 0 Then TabStrip1.Height = UserDocument.ScaleHeight - TabStrip1.Top - 120
If UserDocument.ScaleWidth - 480 > 0 Then ListViewResult(1).Width = UserDocument.ScaleWidth - 480
If UserDocument.ScaleHeight - ListViewResult(1).Top - 240 > 0 Then ListViewResult(1).Height = UserDocument.ScaleHeight - ListViewResult(1).Top - 240
For n% = 2 To TabStrip1.Tabs.Count
   ListViewResult(n%).Width = ListViewResult(1).Width
   ListViewResult(n%).Height = ListViewResult(1).Height
Next

End Sub

Public Sub InitDoc(VBInst As VBIDE.VBE, C As Connect)

Set VBInstance = VBInst
Set Connect = C
Set mVBProjectsEvents = VBInstance.VBProjects
setze_projekte
Init False

End Sub

Private Sub mVBProjectsEvents_ItemAdded(ByVal VBProject As VBIDE.VBProject)
ComboProjekt.AddItem VBProject.Name
C_Analyse.Enabled = True
If ComboProjekt.ListIndex = -1 Then ComboProjekt.ListIndex = 0
Init False
End Sub

Private Sub mVBProjectsEvents_ItemRemoved(ByVal VBProject As VBIDE.VBProject)
For n% = 1 To ComboProjekt.ListCount
   If ComboProjekt.List(n% - 1) = VBProject.Name Then ComboProjekt.RemoveItem n% - 1: Exit For
Next
C_Analyse.Enabled = ComboProjekt.ListCount > 0
If ComboProjekt.ListIndex = -1 Then If ComboProjekt.ListCount > 0 Then ComboProjekt.ListIndex = 0 Else ComboModul.Clear
Init False
End Sub

Private Sub mVBProjectsEvents_ItemRenamed(ByVal VBProject As VBIDE.VBProject, ByVal OldName As String)
For n% = 1 To ComboProjekt.ListCount
   If ComboProjekt.List(n% - 1) = OldName Then ComboProjekt.List(n% - 1) = VBProject.Name: Exit For
Next
End Sub

Private Sub mVBComponentsEvents_ItemAdded(ByVal VBComponent As VBIDE.VBComponent)
ComboModul.AddItem VBComponent.Name
Init False
End Sub

Private Sub mVBComponentsEvents_ItemRemoved(ByVal VBComponent As VBIDE.VBComponent)
For n% = 2 To ComboModul.ListCount
   If ComboModul.List(n% - 1) = VBComponent.Name Then ComboModul.RemoveItem n% - 1: Exit For
Next
If ComboModul.ListIndex = -1 Then ComboModul.ListIndex = 0
Init False
End Sub

Private Sub mVBComponentsEvents_ItemRenamed(ByVal VBComponent As VBIDE.VBComponent, ByVal OldName As String)
For n% = 2 To ComboModul.ListCount
   If ComboModul.List(n% - 1) = OldName Then ComboModul.List(n% - 1) = VBComponent.Name: Exit For
Next
Init False
End Sub

Function FindProcNamesType(currentmodule%, PName$) As ProcNamesType

Dim proc As ProcNamesType

Set FindProcNamesType = Nothing
For n% = 1 To ProcNamesCollection.Count
   Set proc = ProcNamesCollection(n%)
   If proc.Module = currentmodule% And proc.Name = PName$ Then Set FindProcNamesType = proc: Exit For
Next

End Function

Function isExisting%(comp As VBComponent, PName$, typ%)

r% = 0
On Error Resume Next
r% = comp.CodeModule.ProcCountLines(PName$, typ%)
On Error GoTo 0
isExisting% = r% > 0

End Function