Hallo Wissende,
ich häng da zwar in Excel-Vba dran, aber da ist kaum Excel dran, eher alles VB *schätz*
Im Endziel soll in alle Prozeduren eines Projektes das Gleiche eingefügt werden, oben
On Error Goto Errorhandler
unten dann
Errorhandler:
Call Globalerrorhandler(Prozedurname, Err)
Jetzt fand ich Code in die richtige Richtung, leider stimmt was innerhalb der MDL-Schleife nicht, denn der Code funktioniert nurv einaml, im Modul „DieseArbeitsmappe“ der fremden Mappe, er soll aber in alle Module und in alle Prozeduren etwas eintragen, im Beispiel
den Konstantenname.
„FehlerKonstanteTest.xls“ ist nur eine test.xls mit paar Modulen und prozeduren. IN VB kann man da ja ein anderes projekt nehmen.
Danke ^ Gruß
Reinhard
In Modul1:
Option Explicit
Option Compare Text
' By Chip Pearson, www.cpearson.com, [email protected]
Private Const C\_MSGBOX\_TITLE = "Insert Procedure Names"
Private Const C\_VBE\_CONST\_TAG = "\_\_INSERTCONSTLINE\_\_"
Private Const C\_VBE\_INSERT\_MENU As Long = 30005
Sub KonstanteEinfuegen()
'Verweis auf Microsoft Visual Basic for Applications Extensibility 5.3
Dim wkb As Workbook
Set wkb = Workbooks("FehlerKonstanteTest.xls")
Call InsertProcedureNameIntoProcedures(wkb)
End Sub
Sub InsertProcedureNameIntoProcedures(ByRef wkb As Workbook)
'Verweis auf Microsoft Visual Basic for Applications Extensibility 5.3
Const C\_PROC\_NAME = "InsertProcedureNameIntoProcedure"
Dim ProcName As String, ProcLine As String, ProcType As VBIDE.vbext\_ProcKind
Dim StartLine As Long, Msg As String, VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule, Ndx As Long, Res As Variant
Dim Done As Boolean, ProcBodyLine As Long, SaveProcName As String
Dim ConstName As String, ValidConstName As Boolean, ConstAtLine As Long
Dim EndOfDeclaration As Long, Mdl
With wkb
If .VBProject.Protection = vbext\_pp\_locked Then
MsgBox "Der Code von" & vbCr & wkb & vbCr & "ist geperrt."
Exit Sub
End If
ConstName = InputBox(prompt:="Enter a constant name (e.g. 'C\_PROC\_NAME') that will be used as " & vbCrLf & \_
"the constant in which to store the procedure name.", Title:=C\_MSGBOX\_TITLE)
If Trim(ConstName) = vbNullString Then
Exit Sub
End If
If IsValidConstantName(ConstName) = False Then
MsgBox "The constant name: '" & ConstName & "' is invalid.", vbOKOnly, C\_MSGBOX\_TITLE
Exit Sub
End If
For Each Mdl In .VBProject.VBComponents
MsgBox Mdl.Name
Set CodeMod = Mdl.CodeModule
StartLine = CodeMod.CountOfDeclarationLines + 1
ProcName = CodeMod.ProcOfLine(StartLine, ProcType)
SaveProcName = ProcName
Do Until Done
ProcBodyLine = CodeMod.ProcBodyLine(ProcName, ProcType)
ConstAtLine = ConstNameInProcedure(ConstName, CodeMod, ProcName, ProcType)
If ConstAtLine \> 0 Then
CodeMod.DeleteLines ConstAtLine, 1
CodeMod.InsertLines ConstAtLine, "CONST " & ConstName & " = " & Chr(34) & ProcName & Chr(34)
Else
EndOfDeclaration = EndOfDeclarationLines(CodeMod, ProcName, ProcType)
ProcLine = EndOfCommentOfProc(CodeMod, EndOfDeclaration + 1)
CodeMod.InsertLines ProcLine + 1, "CONST " & ConstName & " = " & Chr(34) & ProcName & Chr(34)
End If
StartLine = ProcBodyLine + CodeMod.ProcCountLines(ProcName, ProcType) + 1
ProcName = CodeMod.ProcOfLine(StartLine, ProcType)
If ProcName = SaveProcName Then
Done = True
Else
SaveProcName = ProcName
End If
Loop
Next Mdl
End With
End Sub
Function EndOfCommentOfProc(CodeMod As VBIDE.CodeModule, ProcBodyLine As Long) As Long
Dim Done As Boolean, LineNum As String, LineText As String
LineNum = ProcBodyLine
Do Until Done
LineNum = LineNum + 1
LineText = CodeMod.Lines(LineNum, 1)
If Left(Trim(LineText), 1) = "'" Then
Done = False
Else
Done = True
End If
Loop
EndOfCommentOfProc = LineNum - 1
End Function
Function IsValidConstantName(ConstName As String) As Boolean
Const C\_PROC\_NAME = "IsValidConstantName"
Dim C As String, N As Long, CAsc As Integer
If InStr(1, ConstName, " ") \> 0 Then
IsValidConstantName = False
Exit Function
End If
If IsNumeric(Left(ConstName, 1)) = True Then
IsValidConstantName = False
Exit Function
End If
For N = 2 To Len(ConstName)
C = Mid(ConstName, N, 1)
CAsc = Asc(C)
Select Case CAsc
Case Asc("a") To Asc("z")
Case Asc("A") To Asc("Z")
Case Asc("0") To Asc("9")
Case Asc("\_")
Case Else
IsValidConstantName = False
Exit Function
End Select
Next N
IsValidConstantName = True
End Function
Function ConstNameInProcedure(ConstName As String, CodeMod As VBIDE.CodeModule, \_
ProcName As String, ProcType As VBIDE.vbext\_ProcKind) As Long
Const C\_PROC\_NAME = "ConstNameInProcedure"
Dim LineNum As Long, LineText As String, ProcBodyLine As Long
ProcBodyLine = CodeMod.ProcBodyLine(ProcName, ProcType)
For LineNum = ProcBodyLine To ProcBodyLine + CodeMod.ProcCountLines(ProcName, ProcType)
LineText = CodeMod.Lines(LineNum, 1)
If InStr(LineText, " " & ConstName & " ") \> 0 Then
ConstNameInProcedure = LineNum
Exit Function
End If
Next LineNum
End Function
Function EndOfDeclarationLines(CodeMod As VBIDE.CodeModule, ProcName As String, \_
ProcType As VBIDE.vbext\_ProcKind) As Long
Const C\_PROC\_NAME = "EndOfDeclarationLines"
Dim LineNum As Long, LineText As String
LineNum = CodeMod.ProcBodyLine(ProcName, ProcType)
Do Until Right(CodeMod.Lines(LineNum, 1), 1) "\_"
LineNum = LineNum + 1
Loop
EndOfDeclarationLines = LineNum
End Function