|
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
|
|
|
|
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 ]
|
|
|