Kontextmenü für Textboxen
KLE
Ich nutze für eine Userform, welche verschieden Textboxen etc. enthält den unten aufgeführten Code, um den Textboxen ein "Kontext-Menü" zu geben, damit der User einfacher mit Kopieren, Einfügen, Ausschneidern etc. arbeiten kann.
Bis gestern lief alles super - doch heute die Datei gestartet und jetzt erhalte ich eine Fehlermeldung:
Fehler: -2147467259(80004005):
Die Methode "ShowPopup" für das Objekt 'CommandBar' ist fehlgeschlagen.
Hat jemand eine Idee? Warum läuft es Wochenlang und ann aufeinmal nich mehr ?!?
Gruß und Danke
Kay
Modul1:
Option Explicit
Private WithEvents e_TextBox As MSForms.TextBox
Private m_objForm As Object
Private m_objCBar As Office.CommandBar
Private Sub Class_Terminate()
Set m_objCBar = Nothing
Set e_TextBox = Nothing
Set m_objForm = Nothing
End Sub
Public Property Set Form(ByVal objForm As Object)
Set m_objForm = objForm
End Property
Public Property Set TextBox(ByVal objTextBox As MSForms.TextBox)
Set e_TextBox = objTextBox
End Property
Public Property Set CBar(ByVal objCBar As Office.CommandBar)
Set m_objCBar = objCBar
End Property
Private Sub e_TextBox_MouseUp(ByVal Button As Integer, ByVal _
Shift As Integer, ByVal x As Single, ByVal y As Single)
On Error Resume Next
If Button = 2 And Shift = 0 Then
Set m_objForm.ActiveTextBox = e_TextBox
With m_objCBar
.Controls(1).Enabled = CBool(e_TextBox.SelLength 0)
.Controls(2).Enabled = CBool(e_TextBox.SelLength 0)
.Controls(3).Enabled = e_TextBox.CanPaste
.Controls(4).Enabled = CBool(Len(e_TextBox.Text) 0)
.Controls(5).Enabled = CBool(Len(e_TextBox.Text) 0)
End With
m_objCBar.ShowPopup
End If
End Sub
& Modul2:
Option Explicit
Private mcol_TextBoxes As Collection
Private m_objForm As Object
Private m_objCBar As Office.CommandBar
Private WithEvents e_cbbCut As Office.CommandBarButton
Private WithEvents e_cbbCopy As Office.CommandBarButton
Private WithEvents e_cbbPaste As Office.CommandBarButton
Private WithEvents e_cbbDelete As Office.CommandBarButton
Private WithEvents e_cbbSelect As Office.CommandBarButton
Private Sub Class_Initialize()
Set mcol_TextBoxes = New Collection
End Sub
Private Sub Class_Terminate()
Set mcol_TextBoxes = Nothing
Set m_objForm = Nothing
Set e_cbbCut = Nothing
Set e_cbbCopy = Nothing
Set e_cbbPaste = Nothing
Set e_cbbDelete = Nothing
Set e_cbbSelect = Nothing
If (Not m_objCBar Is Nothing) Then
m_objCBar.Delete
Set m_objCBar = Nothing
End If
End Sub
Public Function CreateCommandBar() As Boolean
On Error GoTo err_CreateCBar
Set m_objCBar = Application.CommandBars.Add( _
Position:=msoBarPopup, Temporary:=True)
Set e_cbbCut = m_objCBar.Controls.Add(Type:=msoControlButton)
With e_cbbCut
.Style = msoButtonIconAndCaption
.Caption = "Ausschneiden"
.FaceId = 21
End With
Set e_cbbCopy = m_objCBar.Controls.Add(Type:=msoControlButton)
With e_cbbCopy
.Style = msoButtonIconAndCaption
.Caption = "Kopieren"
.FaceId = 19
End With
Set e_cbbPaste = m_objCBar.Controls.Add(Type:=msoControlButton)
With e_cbbPaste
.Style = msoButtonIconAndCaption
.Caption = "Einfügen"
.FaceId = 22
End With
Set e_cbbDelete = m_objCBar.Controls.Add(Type:=msoControlButton)
With e_cbbDelete
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "Alles löschen"
End With
Set e_cbbSelect = m_objCBar.Controls.Add(Type:=msoControlButton)
With e_cbbSelect
.Style = msoButtonIconAndCaption
.Caption = "Alles markieren"
End With
CreateCommandBar = True
exit_Func:
On Error GoTo 0
Exit Function
err_CreateCBar:
MsgBox "Fehler: " & Err.Number & vbCrLf & _
Err.Description, vbOKOnly + vbCritical
If (Not m_objCBar Is Nothing) Then
m_objCBar.Delete
Set m_objCBar = Nothing
End If
Resume exit_Func
End Function
Public Property Set Form(ByVal objForm As Object)
Set m_objForm = objForm
End Property
Public Function Add(ByVal objTextBox As MSForms.TextBox) _
As CTextBoxPopUp
Dim objCTextBox As CTextBoxPopUp
On Error GoTo err_Add
Set objCTextBox = New CTextBoxPopUp
With objCTextBox
Set .Form = m_objForm
Set .TextBox = objTextBox
Set .CBar = m_objCBar
End With
mcol_TextBoxes.Add objCTextBox
Set Add = objCTextBox
Set objCTextBox = Nothing
exit_Func:
On Error GoTo 0
Exit Function
err_Add:
MsgBox "Fehler: " & Err.Number & vbCrLf & _
Err.Description, vbOKOnly + vbCritical
Resume exit_Func
End Function
Public Property Get Item(ByVal Index As Variant) As CTextBoxPopUp
Set Item = mcol_TextBoxes.Item(Index)
End Property
Public Property Get Count() As Long
Count = mcol_TextBoxes.Count
End Property
Public Sub Remove(ByVal Index As Variant)
mcol_TextBoxes.Remove Index
End Sub
Private Sub e_cbbCut_Click(ByVal Ctrl As Office. _
CommandBarButton, CancelDefault As Boolean)
m_objForm.ActiveTextBox.Cut
End Sub
Private Sub e_cbbCopy_Click(ByVal Ctrl As Office. _
CommandBarButton, CancelDefault As Boolean)
m_objForm.ActiveTextBox.Copy
End Sub
Private Sub e_cbbPaste_Click(ByVal Ctrl As Office. _
CommandBarButton, CancelDefault As Boolean)
m_objForm.ActiveTextBox.Paste
End Sub
Private Sub e_cbbDelete_Click(ByVal Ctrl As Office. _
CommandBarButton, CancelDefault As Boolean)
m_objForm.ActiveTextBox.Text = vbNullString
End Sub
Private Sub e_cbbSelect_Click(ByVal Ctrl As Office. _
CommandBarButton, CancelDefault As Boolean)
With m_objForm.ActiveTextBox
.SelStart = 0
.SelLength = Len(.Text)
End With
End Sub
