Hallo Peter!<o:p></o:p>
Ich hatte dich am Bratwurstabend der SNEK darauf angesprochen: - hier der Code:<o:p></o:p>
erst mal das Modul:<o:p></o:p>
Option Compare Database<o:p></o:p>
Private MenuEvent As CVBECommandHandler
Private CmdBarItem As CommandBarControl
Private EventHandlers As New Collection<o:p></o:p>
Private Const C_INDENT = 4<o:p></o:p>
'''''''''''''''''''''''''''''''''''''''''''''''''
' The C_TAG constant is used to identify controls
' added by this project. You should change the
' value of this constant to something unique. It
' will be used to delete the controls when the
' workbook is closed and the project is unloaded.
'''''''''''''''''''''''''''''''''''''''''''''''''
Private Const C_TAG = "MY_VBE_TAG"<o:p></o:p>
Sub AddNewVBEControls()<o:p></o:p>
Dim Ctrl As Office.CommandBarControl<o:p></o:p>
'''''''''''''''''''''''''''''''''''''''''''''''''
' Delete any existing controls with our Tag.
'''''''''''''''''''''''''''''''''''''''''''''''''
Set Ctrl = Application.VBE.CommandBars.FindControl(Tag:=C_TAG)
Do Until Ctrl Is Nothing
Ctrl.Delete
Set Ctrl =
Application.VBE.CommandBars.FindControl(Tag:=C_TAG)
Loop<o:p></o:p>
'''''''''''''''''''''''''''''''''''''''''''''''''
' Delete any existing event handlers.
'''''''''''''''''''''''''''''''''''''''''''''''''
Do Until EventHandlers.Count = 0
EventHandlers.Remove 1
Loop<o:p></o:p>
'''''''''''''''''''''''''''''''''''''''''''''''''
' add the first control to the Tools menu.
'''''''''''''''''''''''''''''''''''''''''''''''''
Set MenuEvent = New CVBECommandHandler
With Application.VBE.CommandBars("Menüleiste").Controls("Extras")
Set CmdBarItem = .Controls.Add
End With
With CmdBarItem
.Caption = "First Item"
.BeginGroup = True
.OnAction = "Procedure_One"
.Tag = C_TAG
End With<o:p></o:p>
Set MenuEvent.EvtHandler = Application.VBE.Events.CommandBarEvents(CmdBarItem)
EventHandlers.Add MenuEvent<o:p></o:p>
'''''''''''''''''''''''''''''''''''''''''''''''''
' add the second control to the Tools menu.
'''''''''''''''''''''''''''''''''''''''''''''''''
Set MenuEvent = New CVBECommandHandler
With Application.VBE.CommandBars("Menüleiste").Controls("Extras")
Set CmdBarItem = .Controls.Add
End With
With CmdBarItem
.Caption = "Second Item"
.BeginGroup = False
.OnAction = "Procedure_Two"
.Tag = C_TAG
End With<o:p></o:p>
Set MenuEvent.EvtHandler = Application.VBE.Events.CommandBarEvents(CmdBarItem)
EventHandlers.Add MenuEvent<o:p></o:p>
'''''''''''''''''''''''''''''''''''''''''''''''''
' add the third control to the Tools menu.
'''''''''''''''''''''''''''''''''''''''''''''''''
Set MenuEvent = New CVBECommandHandler
With
Application.VBE.CommandBars("Menüleiste").Controls("Extras")
Set CmdBarItem = .Controls.Add
End With
With CmdBarItem
.Caption = "Format Lines"
.BeginGroup = True
.OnAction = "FormatLines"
.Tag = C_TAG
End With<o:p></o:p>
Set MenuEvent.EvtHandler = Application.VBE.Events.CommandBarEvents(CmdBarItem)
EventHandlers.Add MenuEvent<o:p></o:p>
End Sub<o:p></o:p>
Sub DeleteMenuItems()
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' This procedure deletes all controls that have a
' tag of C_TAG.
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ctrl As Office.CommandBarControl
Set Ctrl =
Application.VBE.CommandBars.FindControl(Tag:=C_TAG)
Do Until Ctrl Is Nothing
Ctrl.Delete
Set Ctrl =
Application.VBE.CommandBars.FindControl(Tag:=C_TAG)
Loop
End Sub<o:p></o:p>
Public Sub Procedure_One()
MsgBox "Procedure One"
End Sub<o:p></o:p>
Public Sub Procedure_Two()
MsgBox "Procedure Two"
End Sub<o:p></o:p>
Public Sub Auto_Open()
AddNewVBEControls
End Sub<o:p></o:p>
Public Sub Auto_Close()
DeleteMenuItems
End Sub<o:p></o:p>
Public Sub FormatLines()
Dim objcm As CodeModule
Dim lngStartLine As Long, lngEndLine As Long
Dim lngStartColumn As Long, lngEndColumn As Long
Dim strSelection As String
Dim strWork As String
Dim i As Long
Dim lngIndent As Long
Set objcm = VBE.ActiveCodePane.CodeModule
VBE.ActiveCodePane.GetSelection lngStartLine, lngStartColumn, lngEndLine, lngEndColumn<o:p></o:p>
For i = lngStartLine To lngEndLine
If i = lngStartLine Then
strSelection = objcm.Lines(i, 1)
Do While Left(strSelection, 1) = " "
lngIndent = lngIndent + 1
strSelection = Mid(strSelection, 2)
Loop
lngIndent = lngIndent / C_INDENT
strSelection = Trim(strSelection)
Else
strSelection = Trim(objcm.Lines(i, 1))
End If
strWork = String(lngIndent * C_INDENT, " ") & strSelection
If Left(strSelection, 3) = "If " Then lngIndent = lngIndent + 1
If InStr(6, strSelection, " then ") And Right(Trim(strSelection), 4) <> "Then" Then lngIndent = lngIndent
- 1
If Left(strSelection, 6) = "End If" Then
lngIndent = lngIndent - 1
strWork = String(lngIndent * C_INDENT, " ") & strSelection
End If
Debug.Print strWork
'objcm.ReplaceLine i, strWork
Next<o:p></o:p>
End Sub<o:p></o:p>
und jetzt
noch die Klasse:<o:p></o:p>
Private Sub EvtHandler_Click(ByVal CommandBarControl
As Object, _
Handled As Boolean, CancelDefault As Boolean)
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' This is called when a item is clicked. Call the
' procedure named in the OnAction property of the
' CommandBarControl passed into this procedure.
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Application.Run CommandBarControl.OnAction
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' Tell VBIDE that we've handled the event.
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Handled = False
CancelDefault = False
End Sub<o:p></o:p>
Ich kann
bei dem Projket nicht an die Registry und daher auch kein Add-In erstellen,
deshalb habe ich die Menü-Items einfach mit normalem Code erzeugt. Klappt auch.<o:p></o:p>
Mit
Auto_Open erzeuge ich zwei Dummy-Items, dann das Item FormatLines, welches auch
die entsprechende Prozedur aufruft.<o:p></o:p>
Wie du siehst, ist das fette ReplaceLine auskommentiert. Lässt man das Ganze laufen,
funktioniert alles wunderbar, der markierte Code wird formatiert (in diesem
Testzustand wird nur IF/End Ifbetrachtet, damit es übersichtlicher bleibt) und als Debug
ausgegeben. Und das auch problemlos mehrmals hintereinander.<o:p></o:p>
Jetzt kommt das Problem. Wenn ich das ReplaceLine wieder in das Programm nehme -
funktioniert alles wunderbar, aber nur genau einmal. Rufe ich die Prozedur
erneut auf, dann tut sich gar nichts mehr.<o:p></o:p>
Dann mache ich ein Auto-Open, die Befehle werden gelöscht und neu erzeugt, und alles
funktioniert.<o:p></o:p>
Einmal.<o:p></o:p>
Hast Du
eine Idee????<o:p></o:p>
Grüße<o:p></o:p>
Roland<o:p></o:p>
It's no problem, it's just the syntax
