Tipp 0434 TextBox mit Kontextmenü (UserForm)
Autor/Einsender:
Datum:
  Angie
22.01.2005
Entwicklungsumgebung:   Excel 2000
Mit einer Symbolleiste kann auf recht einfach Art und Weise ein Kontextmenü für eine TextBox (MSForms.TextBox) erstellt werden. Dazu wird eine Symbolleiste (Befehlsleiste) erstellt und mit dem Parameter Position (Konstante msoBarPopup) angegeben, dass die neue Symbolleiste ein Kontextmenü ist. In diesem Beispiel wird dem Anwender die Möglichkeit geboten, Text auszuschneiden, zu kopieren, einzufügen, zu löschen oder aber auch zu markieren.
Für die Ausführung des Tipps werden zwei Klassenmodule benötigt, eins für das eigentliche Objekt (hier die TextBox) und ein zweites für die Auflistung der Objekte.
Code im Codebereich des Klassenmoduls CTextBoxPopUp
Im Klassenmodul CTextBoxPopUp werden alle Objekt-spezifischen Eigenschaften, Methoden und Ereignisse untergebracht, hier die der TextBox zugehörigen UserForm und Symbolleiste und das MouseUp-Ereignis der TextBox, in der das Kontextmenü mit der ShowPopup-Methode angezeigt wird. Vor Anzeige des Kontextmenüs können die CommandBarButtons ggf. aktiviert/deaktiviert werden.
Diese Klasse dient als Vorlage, aus der eine Objektinstanz zur Laufzeit erzeugt wird. Es wird für jede TextBox, zu der ein Kontextmenü hinzugefügt werden soll, eine Objektinstanz erstellt.
 
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)

  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
 
Code im Codebereich des Klassenmoduls col_CTextBoxPopUp
In der Auflistungsklasse col_CTextBoxPopUp (Collection) befindet sich unter anderem die Funktion für die Erstellung der Symbolleiste, die Click-Ereignisse der CommandBarButtons als auch die Add-Methode, mit der der Auflistung neue Objekte hinzugefügt werden. Die Objektdaten werden in einem Collection-Objekt gespeichert.
 
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
 
Code im Codebereich der UserForm
Im Initialize-Ereignis der UserForm wird die Auflistungsklasse (Collection) initialisiert und die TextBoxen zur Collection hinzugefügt, bei denen ein Kontextmenü angezeigt werden soll.
 
Option Explicit

Private mcol_TextBoxes  As col_CTextBoxPopUp
Private m_objActiveTB   As MSForms.TextBox

Private Sub UserForm_Initialize()
  Set mcol_TextBoxes = New col_CTextBoxPopUp

  If mcol_TextBoxes.CreateCommandBar Then
    Set mcol_TextBoxes.Form = Me

    Dim objCtl As MSForms.Control

    For Each objCtl In Me.Controls
      If TypeOf objCtl Is MSForms.TextBox Then
        mcol_TextBoxes.Add objCtl
      End If
    Next
  End If

  Me.lblMessage.Caption = mcol_TextBoxes.Count & _
      " TextBoxen mit Kontextmenü auf dieser UserForm!"
End Sub

Private Sub UserForm_Terminate()
  Set m_objActiveTB = Nothing
  Set mcol_TextBoxes = Nothing
End Sub

Public Property Set ActiveTextBox(ByVal objTextBox As _
      MSForms.TextBox)
  Set m_objActiveTB = objTextBox
End Property

Public Property Get ActiveTextBox() As MSForms.TextBox
  Set ActiveTextBox = m_objActiveTB
End Property
 
Hinweise
Um diesen Tipp ausführen zu können, muss die Microsoft Office x.0 Object Library im Projekt eingebunden werden.
In den im Download befindlichen *.frm- und *.cls-Dateien ist der Code ausführlich kommentiert. Die Dateien können für Word und PowerPoint im jeweiligen Programm im VB-Editor importiert werden.

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
Anwendung/VBA-Version
Access 97
Access 2000
Access XP
Access 2003
Access 2007
Access 2010
Excel 97
Excel 2000
Excel XP
Excel 2003
Excel 2007
Excel 2010
Word 97
Word 2000
Word XP
Word 2003
Word 2007
Word 2010
PPT 97
PPT 2000
PPT XP
PPT 2003
PPT 2007
PPT 2010
Outlook 97
Outlook 2000
Outlook XP
Outlook 2003
Outlook 2007
Outlook 2010


Download  (50 kB) Downloads bisher: [ 1487 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 22. Mai 2011