Code läuft nur in einem Modul :-(
02.03.2011 12:58:40
Reinhard
Hallo Holger,
ich bon jetzt soweit, daß das Makro zumindest schon einmal läuft, d.h. im obersten Modul "DieseArbeitsmappe" trägt es die Konstante in die Prozedur die da steht ein.
Leider macht sie das in anderen Modulen noch nicht :-(
Irgednwas läuft da innerhalb des Fettgedruckten schief...
Nachstehende der Code der Datei:
https://www.herber.de/bbs/user/73801.xls
Wie du u.a. in "DieseArbeitsmappe" erkennst habe ich mir eine "FehlerKonstanteTest.xls" mit allen möglichen Modulen gebastelt, mach das auch zum Testen.
Gruß
Reinhard
Code in Modul1:
Option Explicit
Option Compare Text
' By Chip Pearson, www.cpearson.com, chip@cpearson.com
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