Excel-Standard

VBA (Makros)

Allgemein

Probleme mit Excel

Autor: Max Kaffl (Nepumuk) --- Aus Excel VBA - Gruppe: Tutorials

Symbolleisten (4) - Pop Up (Ab E2000) - Weiter heftig!!!

Autor: Max Kaffl (Nepumuk) - Erstellt: -- - Letzte Revision: --Gruppenthema: 5 Folgen 1 2 3 4 5 Sie sind in Folge:4

Im vierten Teil der als Trilogie geplanten Reihe werden sie das Popup - Menü kennen lernen.

Dieser Code ist erst ab Excel 2000 lauffähig!

Das liegt daran, dass in den Übergabeparametern enumerierte Variablen verwendet werden. Diese wurden schon im dritten Teil erwähnt.

Auch hier gilt wieder: Sollte Excel völlig unerwartet abstürzen, während die Symbolleiste geändert ist, können sie diese Änderung durch erneutes öffnen und schließen der Mappe zurücksetzen.

Als kleine Aufwärmübung wollen wir ein Popup erstellen, welches durch den Rechtsklick auf einen Tabellenreiter erscheint.

Nun gut, da gibt es ja schon eines, welches wir deaktivieren könnten. Aber wie bekommen wir dann ein eigenes? In Excel gibt es keine Möglichkeit, den Rechtsklick auf einen Tabellenreiter auszuwerten. Also übernehmen wir das vorhandene Popup und frisieren es um.

Dazu löschen wir die vorhandenen Einträge in einer For Each - Next Schleife. Die leere Leiste wird dann mit eigenen Buttons bestückt. Sie können aber auch andere Steuerelemente in die Leiste packen. Wir bedienen uns hierbei der Methoden aus dem dritten Teil.

Fügen sie die folgenden Hauptroutinen in ein Standardmodul ein.

Option Explicit
Option Private Module

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
 ByVal DirPath As String) As Long
 
Private Const FILE_NAME As String = "NeueDaten.xls"
Private Const FILE_PATH As String = "C:\Temp\"
Private Const MAIL_ADDRESS As String = "xxxxx@yyyyy.zz" 'Mailadresse !!!

Public Sub prcChangeMenu()
 Dim cmdCommandBar As CommandBar
 Dim cmdCommandBarControl As CommandBarControl
 Set cmdCommandBar = Application.CommandBars("Ply")
 For Each cmdCommandBarControl In cmdCommandBar.Controls
 cmdCommandBarControl.Delete
 Next
 Call prcControlAdd(objParent:=cmdCommandBar, enumType:=msoControlButton, _
 varCaption:="Aufsteigend sortieren", varFaceId:=210, _

 varOnAction:="prcSort", enumStyle:=msoButtonIconAndCaption, _
 varTag:="1")
 Call prcControlAdd(objParent:=cmdCommandBar, enumType:=msoControlButton, _
 varCaption:="Absteigend sortieren", varFaceId:=211, _
 varOnAction:="prcSort", enumStyle:=msoButtonIconAndCaption, _
 varTag:="0")
 Call prcControlAdd(objParent:=cmdCommandBar, enumType:=msoControlButton, _
 varCaption:="Monatstabelle einfügen", varFaceId:=635, _
 varOnAction:="prcInsertNewMonth", enumStyle:=msoButtonIconAndCaption)
 Call prcControlAdd(objParent:=cmdCommandBar, enumType:=msoControlButton, _
 bolBeginGroup:=True, varCaption:="Als Mailanhang senden", _
 varFaceId:=2188, varOnAction:="prcMail", _
 enumStyle:=msoButtonIconAndCaption)
 Set cmdCommandBar = Nothing
End Sub

Public Sub prcResetMenu()
 Application.CommandBars("Ply").Reset
End Sub

Private Sub prcControlAdd( _
 ByRef objParent As Object, _
 Optional ByRef varControl As Variant, _
 Optional ByVal enumType As MsoControlType, _
 Optional ByVal varId As Variant, _
 Optional ByVal varBefore As Variant, _
 Optional ByVal varTemporary As Variant, _
 Optional ByVal bolBeginGroup As Boolean = False, _
 Optional ByVal varCaption As Variant, _
 Optional ByVal varFaceId As Variant, _
 Optional ByVal varOnAction As Variant, _
 Optional ByVal enumStyle As MsoButtonStyle, _
 Optional ByVal varTipText As Variant, _
 Optional ByVal enumState As MsoButtonState, _
 Optional ByVal varTag As Variant, _
 Optional ByVal enumLinkType As MsoCommandBarButtonHyperlinkType, _
 Optional ByVal bolEnabled As Boolean = True, _
 Optional ByVal bolVisible As Boolean = True)
 Dim cmbControl As CommandBarControl
 Select Case IIf(enumType, 1, 0) & IIf(IsMissing(varId), 0, 1) & _
 IIf(IsMissing(varBefore), 0, 1) & IIf(IsMissing(varTemporary), 0, 1)
 Case "0100": Set cmbControl = objParent.Controls.Add(ID:=varId)
 Case "0101": Set cmbControl = objParent.Controls.Add(ID:=varId, _
  Temporary:=varTemporary)
 Case "0110": Set cmbControl = objParent.Controls.Add(ID:=varId, _
  Before:=varBefore)
 Case "0111": Set cmbControl = objParent.Controls.Add(ID:=varId, _
  Before:=varBefore, Temporary:=varTemporary)
 Case "1000": Set cmbControl = objParent.Controls.Add(Type:=enumType)
 Case "1001": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  Temporary:=varTemporary)
 Case "1010": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  Before:=varBefore)
 Case "1011": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  Before:=varBefore, Temporary:=varTemporary)
 Case "1100": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  ID:=varId)
 Case "1101": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  ID:=varId, Temporary:=varTemporary)
 Case "1110": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  ID:=varId, Before:=varBefore)
 Case "1111": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  ID:=varId, Before:=varBefore, Temporary:=varTemporary)
 End Select
 With cmbControl
 .BeginGroup = bolBeginGroup
 If Not IsMissing(varCaption) Then .Caption = varCaption
 If Not IsMissing(varFaceId) Then .FaceId = varFaceId
 If Not IsMissing(varOnAction) Then .OnAction = varOnAction
 If enumStyle Then .Style = enumStyle
 If Not IsMissing(varTipText) Then .TooltipText = varTipText
 If enumState Then .State = enumState
 If Not IsMissing(varTag) Then .Tag = varTag
 If enumLinkType Then .HyperlinkType = enumLinkType
 .Enabled = bolEnabled
 .Visible = bolVisible
 End With
 If Not IsMissing(varControl) Then Set varControl = cmbControl
 Set cmbControl = Nothing
End Sub

Dazu gibt es, als Beispiele, ein paar kleine Routinen, welche durch das Popup aufgerufen werden können. Wenn sie eine davon in ihr Projekt integrieren wollen, so müssen sie angepasst werden. Beispielsweise um Fehler abzufangen, oder denken sie bei Tabellenoperationen an den Mappenschutz.

Das erste Makro sortiert die Tabellen nach Namen, aufsteigend oder absteigend.

Das zweite fügt ein Tabellenblatt mit einem definierten Namen hinzu.

Das dritte ruft eine Prozedur auf, die als Standardroutine für den Mailversand mit Outlook dient. Sie wird dazu benutzt, die aktive Tabelle als Anhang an eine Mailadresse zu schicken. Da in dem Makro die Tabelle temporär gespeichert werden muss, wird mit der API - Funktion „MakeSureDirectoryPathExists" sichergestellt, dass der entsprechende Ordner auch existiert. Gibt es ihn, passiert nichts, gibt es ihn nicht, wird er angelegt.

Fügen sie die Makros unter den bestehenden ein.

Private Sub prcSort()
 Dim intSheetCount As Integer
 Dim intIndex1 As Integer, intIndex2 As Integer
 Dim bolAscending As Boolean
 bolAscending = CBool(Application.CommandBars.ActionControl.Tag)
 Application.ScreenUpdating = False
 With ThisWorkbook
 intSheetCount = .Sheets.Count
 For intIndex1 = 1 To intSheetCount
  For intIndex2 = intIndex1 To intSheetCount
  If .Sheets(intIndex2).Visible = xlSheetVisible _
   And .Sheets(intIndex1).Visible = xlSheetVisible Then
   If bolAscending Then
   If UCase$(.Sheets(intIndex2).Name) _
    < UCase$(.Sheets(intIndex1).Name) Then _
    .Sheets(intIndex2).Move Before:=.Sheets(intIndex1)
   Else
   If UCase$(.Sheets(intIndex2).Name) _
    > UCase$(.Sheets(intIndex1).Name) Then _
    .Sheets(intIndex2).Move Before:=.Sheets(intIndex1)
   End If
  End If
  Next
 Next
 End With
 Application.ScreenUpdating = True
End Sub

Private Sub prcInsertNewMonth()
 Dim objSheet As Object
 Dim strSheetname As String
 Dim bolFound As Boolean
 Dim intCount As Integer
 With ThisWorkbook
 Do
  strSheetname = Format(CStr(Year(DateAdd("m", intCount, Date))), "0000") _
  & " " & Format(CStr(Month(DateAdd("m", intCount, Date))), "00")
  For Each objSheet In .Sheets
  If objSheet.Name = strSheetname Then bolFound = True: Exit For
  Next
  If Not bolFound Then
  .Worksheets.Add After:=.Sheets(.Sheets.Count)
  .ActiveSheet.Name = strSheetname
  Exit Do
  Else
  bolFound = False
  End If
  intCount = intCount + 1
 Loop
 End With
End Sub

Private Sub prcMail()
 Dim strBody As String
 MakeSureDirectoryPathExists FILE_PATH
 If Dir(FILE_PATH & FILE_NAME) <> "" Then Kill FILE_PATH & FILE_NAME
 Application.ScreenUpdating = False
 ThisWorkbook.ActiveSheet.Copy
 ActiveWorkbook.Close SaveChanges:=True, Filename:=FILE_PATH & FILE_NAME
 Application.ScreenUpdating = True
'Html - Body
' strBody = "<p>Hallo,</p><p>im Anhang die neuesten Daten.</p>" & _
 "<p>mfg</p><p>Mein Name</p><p>" & CStr(Now) & "</p>"
'Text - Body
 strBody = "Hallo," & vbLf & "im Anhang die neuesten Daten." & _
 vbLf & "mfg " & vbLf & "Mein Name" & vbLf & _
 CStr(Now) & String(3, vbLf)
 Call prcSendMail(bolHtml:=False, bolSend:=False, varTo:=MAIL_ADDRESS, _
 varSubject:="Änderungen vom " & CStr(Date), varMailBody:=strBody, _
 varAttachments:=FILE_PATH & FILE_NAME)
 If Dir(FILE_PATH & FILE_NAME) <> "" Then Kill FILE_PATH & FILE_NAME
End Sub

Private Sub prcSendMail( _
 ByVal bolHtml As Boolean, _
 ByVal bolSend As Boolean, _
 Optional ByVal varTo As Variant, _
 Optional ByVal varCc As Variant, _
 Optional ByVal varBcc As Variant, _
 Optional ByVal varSubject As Variant, _
 Optional ByVal varMailBody As Variant, _
 Optional ByVal varAttachments As Variant)
 Dim objOutlookApplication As Object, objMail As Object
 On Error GoTo Err_Exit
 Set objOutlookApplication = CreateObject(Class:="Outlook.Application")
 Set objMail = objOutlookApplication.CreateItem(0)
 With objMail
 .To = IIf(IsMissing(varTo), "", varTo)
 .Cc = IIf(IsMissing(varCc), "", varCc)
 .Bcc = IIf(IsMissing(varBcc), "", varBcc)
 .Subject = IIf(IsMissing(varSubject), "", varSubject)
 If Not IsMissing(varMailBody) Then If bolHtml Then _
  .HTMLBody = varMailBody Else .Body = varMailBody
 If Not IsMissing(varAttachments) Then .Attachments.Add varAttachments
 If bolSend Then .Send Else .Display
 End With
Err_Exit:
 Select Case Err.Number
 Case 0: If bolSend Then _
  MsgBox "Die Nachricht wurde erfolgreich gesendet.", 64, "Information"
 Case 287: MsgBox " Die Nachricht wurde nicht gesendet," & vbLf & _
  " da Sie den Vorgang abgebrochen haben.", 48, "Hinweis"
 Case Else: MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
  Err.Description, 16, "Fehlermeldung"
 End Select
 Set objOutlookApplication = Nothing
 Set objMail = Nothing
End Sub

Damit die Änderung der Leiste auf diese Mappe beschränkt bleibt, benötigen wir wieder die Ereignisroutinen in deren Klassenmodul. Dabei muss die Leiste beim deaktivieren der Mappe grundsätzlich zurückgesetzt und beim aktivieren gesetzt werden. Aus diesem Grund können wir uns die zusätzlichen Abfragen sparen.

Option Explicit

Private Sub Workbook_Activate()
 Call prcChangeMenu
End Sub

Private Sub Workbook_Deactivate()
 Call prcResetMenu
End Sub

Und weil das so leicht war, gleich noch eins.

Das zweit Popup, welches wird nun komplett selbst erstellen, werden wir in ein Userform integrieren. Legen sie dazu in einer leeren Mappe ein Userform mit einem Commandbutton und mehreren Textboxen (mindestens 3) an.

Kopieren sie den folgenden Code in das Klassenmodul des Userforms.

Starten sie das Userform nicht, sie würden sofort eine Fehlermeldung erhalten.

Option Explicit

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
 ByVal lpClassName As String, _
 ByVal lpWindowName As String) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
 ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long

Dim colTextBox As Collection

Private Sub CommandButton1_Click()
 Unload Me
End Sub

Private Sub UserForm_Activate()
 Dim frmControl As Control
 Dim intCount As Integer
 Dim ctxtTextBox() As New clsTextBox
 OpenClipboard FindWindow("XLMAIN", Application.Caption)
 EmptyClipboard
 CloseClipboard
 Call prcCreateCommandBar
 Set frmForm = Me
 Set colTextBox = New Collection
 For Each frmControl In Controls
 If TypeOf frmControl Is MSForms.TextBox Then
  intCount = colTextBox.Count + 1
  frmControl.Tag = CStr(intCount)
  ReDim Preserve ctxtTextBox(1 To intCount)
  Set ctxtTextBox(intCount).mtxtTextBox = frmControl
  colTextBox.Add ctxtTextBox(intCount)
  frmControl.Value = frmControl.Name
 End If
 Next
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
 Call prcDeleteCommandBar
 Set frmForm = Nothing
 Set colTextBox = Nothing
End Sub

Das erste, was sie in dem Code sehen, sind wieder ein paar API - Aufrufe. Da wir eine Copy & Paste - Funktion in das Popup aufnehmen, ist es ratsam, beim öffnen des Userforms, die Zwischenablage zu löschen. Anschließend wird das Popup angelegt und Textboxen einer Klasse zugewiesen. Dazu gleich mehr.

Im QueryClose - Ereignis des Forms wird die Klasse wieder entladen und das Popup gelöscht.

Um nicht für jede Textbox das selbe Makro schreiben zu müssen, verweisen wir sie an eine neue Klasse. Fügen sie dem Projekt ein Klassenmodul mit dem Namen "clsTextBox" hinzu und kopieren sie in dieses den folgenden Code.

Option Explicit

Public WithEvents mtxtTextBox As MSForms.TextBox

Private Sub mtxtTextBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
 ByVal Shift As Integer)
 If Shift = 2 Then
 Select Case KeyCode
  Case 67: Call prcCopy(False)
  Case 86: Call prcInsert(False)
  Case 88: Call prcCut(False)
 End Select
 End If
End Sub

Private Sub mtxtTextBox_MouseUp(ByVal Button As Integer, _
 ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
 If Button = 2 Then Call prcSetControl(mtxtTextBox.Tag, mtxtTextBox.Locked)
End Sub

Im Klassenmodul der Textboxen wird sowohl das Rechtsklickereignis, als auch die Benutzung der Tastenkombinationen Strg+x, Strg+c und Strg+v an normale Routinen weitergeleitet.

Den Code zum erstellen des Popups und der Copy & Paste - Funktion kopieren sie in ein Standardmodul.

Das Verfahren zum anlegen einer Commandbar kennen sie ja schon aus dem zweiten und dritten Teil. Dazu noch ein paar kleine Beispielroutinen, um den Buttons Funktionen zu verleihen.

In der letzten Routine, in der die Anzeige der verschiedenen Buttons gesteuert wird, sehen sie auch die Anwendung der ShowPopup - Methode, mit der das Popup angezeigt wird.

Option Explicit
Option Private Module

Public Const POPUP_NAME As String = "Private_Poup"

Public frmForm As UserForm

Private cmbmyPopup As CommandBar
Private bolCut As Boolean

Public Sub prcCreateCommandBar()
 Call prcDeleteCommandBar
 Set cmbmyPopup = Application.CommandBars.Add(Name:=POPUP_NAME, _
 Position:=msoBarPopup, MenuBar:=False, Temporary:=True)
 Call prcControlAdd(objParent:=cmbmyPopup, enumType:=msoControlButton, _
 varCaption:="Ausschneiden", varFaceId:=21, varOnAction:="prcCut", _
 enumStyle:=msoButtonIconAndCaption)
 Call prcControlAdd(objParent:=cmbmyPopup, enumType:=msoControlButton, _
 varCaption:="Kopieren", varFaceId:=19, varOnAction:="prcCopy", _
 enumStyle:=msoButtonIconAndCaption)
 Call prcControlAdd(objParent:=cmbmyPopup, enumType:=msoControlButton, _
 varCaption:="Einfügen", varFaceId:=22, varOnAction:="prcInsert", _
 enumStyle:=msoButtonIconAndCaption, bolEnabled:=False)
 Call prcControlAdd(objParent:=cmbmyPopup, enumType:=msoControlButton, _
 bolBeginGroup:=True, varCaption:="Datum eintragen", varFaceId:=1106, _
 varOnAction:="prcDate", enumStyle:=msoButtonIconAndCaption)
 Call prcControlAdd(objParent:=cmbmyPopup, enumType:=msoControlButton, _
 varCaption:="Uhrzeit eintragen", varFaceId:=33, varOnAction:="prcTime", _
 enumStyle:=msoButtonIconAndCaption)
 Call prcControlAdd(objParent:=cmbmyPopup, enumType:=msoControlButton, _
 varCaption:="Benutzer eintragen", varFaceId:=607, varOnAction:="prcUser", _
 enumStyle:=msoButtonIconAndCaption)
 Call prcControlAdd(objParent:=cmbmyPopup, enumType:=msoControlButton, _
 bolBeginGroup:=True, varCaption:="Rückgängig", varFaceId:=128, _
 varOnAction:="prcUndo", enumStyle:=msoButtonIconAndCaption)
 Call prcControlAdd(objParent:=cmbmyPopup, enumType:=msoControlButton, _
 varCaption:="Wiederholen", varFaceId:=129, varOnAction:="prcRedo", _
 enumStyle:=msoButtonIconAndCaption)
 Call prcControlAdd(objParent:=cmbmyPopup, enumType:=msoControlButton, _
 bolBeginGroup:=True, varCaption:="Text drehen", varFaceId:=1146, _
 varOnAction:="prcReverse", enumStyle:=msoButtonIconAndCaption)
End Sub

Public Sub prcDeleteCommandBar()
 Dim cmbCommandBar As CommandBar
 If Not cmbmyPopup Is Nothing Then
 cmbmyPopup.Delete
 Set cmbmyPopup = Nothing
 Else
 For Each cmbCommandBar In Application.CommandBars
  If cmbCommandBar.Name = POPUP_NAME Then cmbCommandBar.Delete
 Next
 End If
End Sub

Private Sub prcControlAdd( _
 ByRef objParent As Object, _
 Optional ByRef varControl As Variant, _
 Optional ByVal enumType As MsoControlType, _
 Optional ByVal varId As Variant, _
 Optional ByVal varBefore As Variant, _
 Optional ByVal varTemporary As Variant, _
 Optional ByVal bolBeginGroup As Boolean = False, _
 Optional ByVal varCaption As Variant, _
 Optional ByVal varFaceId As Variant, _
 Optional ByVal varOnAction As Variant, _
 Optional ByVal enumStyle As MsoButtonStyle, _
 Optional ByVal varTipText As Variant, _
 Optional ByVal enumState As MsoButtonState, _
 Optional ByVal varTag As Variant, _
 Optional ByVal enumLinkType As MsoCommandBarButtonHyperlinkType, _
 Optional ByVal bolEnabled As Boolean = True, _
 Optional ByVal bolVisible As Boolean = True)
 Dim cmbControl As CommandBarControl
 Select Case IIf(enumType, 1, 0) & IIf(IsMissing(varId), 0, 1) & _
 IIf(IsMissing(varBefore), 0, 1) & IIf(IsMissing(varTemporary), 0, 1)
 Case "0100": Set cmbControl = objParent.Controls.Add(ID:=varId)
 Case "0101": Set cmbControl = objParent.Controls.Add(ID:=varId, _
  Temporary:=varTemporary)
 Case "0110": Set cmbControl = objParent.Controls.Add(ID:=varId, _
  Before:=varBefore)
 Case "0111": Set cmbControl = objParent.Controls.Add(ID:=varId, _
  Before:=varBefore, Temporary:=varTemporary)
 Case "1000": Set cmbControl = objParent.Controls.Add(Type:=enumType)
 Case "1001": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  Temporary:=varTemporary)
 Case "1010": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  Before:=varBefore)
 Case "1011": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  Before:=varBefore, Temporary:=varTemporary)
 Case "1100": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  ID:=varId)
 Case "1101": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  ID:=varId, Temporary:=varTemporary)
 Case "1110": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  ID:=varId, Before:=varBefore)
 Case "1111": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
  ID:=varId, Before:=varBefore, Temporary:=varTemporary)
 End Select
 With cmbControl
 .BeginGroup = bolBeginGroup
 If Not IsMissing(varCaption) Then .Caption = varCaption
 If Not IsMissing(varFaceId) Then .FaceId = varFaceId
 If Not IsMissing(varOnAction) Then .OnAction = varOnAction
 If enumStyle Then .Style = enumStyle
 If Not IsMissing(varTipText) Then .TooltipText = varTipText
 If enumState Then .State = enumState
 If Not IsMissing(varTag) Then .Tag = varTag
 If enumLinkType Then .HyperlinkType = enumLinkType
 .Enabled = bolEnabled
 .Visible = bolVisible
 End With
 If Not IsMissing(varControl) Then Set varControl = cmbControl
 Set cmbControl = Nothing
End Sub

Public Sub prcCut(Optional ByVal bolByCommandBar As Boolean = True)
 cmbmyPopup.Controls(3).Enabled = True
 bolCut = True
 If bolByCommandBar Then frmForm.ActiveControl.Cut
End Sub

Public Sub prcCopy(Optional ByVal bolByCommandBar As Boolean = True)
 cmbmyPopup.Controls(3).Enabled = True
 bolCut = False
 If bolByCommandBar Then frmForm.ActiveControl.Copy
End Sub

Public Sub prcInsert(Optional ByVal bolByCommandBar As Boolean = True)
 If bolCut Then
 cmbmyPopup.Controls(3).Enabled = False
 bolCut = False
 End If
 If bolByCommandBar Then frmForm.ActiveControl.Paste
End Sub

Private Sub prcDate()
 frmForm.ActiveControl.Value = CStr(Date)
End Sub

Private Sub prcTime()
 frmForm.ActiveControl.Value = CStr(Time)
End Sub

Private Sub prcUser()
 frmForm.ActiveControl.Value = Application.UserName
End Sub

Private Sub prcUndo()
 frmForm.UndoAction
End Sub

Private Sub prcRedo()
 frmForm.RedoAction
End Sub

Private Sub prcReverse()
 Dim intIndex As Integer
 Dim strBuffer As String, strTemp As String
 With frmForm.ActiveControl
 If Val(Application.Version) > 8 Then
  .Value = Left$(.Text, .SelStart) & _
  StrReverse$(Mid$(.Text, .SelStart + 1, .SelLength)) _
  & Right$(.Text, .TextLength - .SelStart - .SelLength)
 Else
  strTemp = Mid$(.Text, .SelStart + 1, .SelLength)
  For intIndex = Len(strTemp) To 1 Step -1
  strBuffer = strBuffer & Mid$(strTemp, intIndex, 1)
  Next
  .Value = Left$(.Text, .SelStart) & strBuffer _
  & Right$(.Text, .TextLength - .SelStart - .SelLength)
 End If
 End With
End Sub

Public Sub prcSetControl(ByVal strTag As String, bolLocked As Boolean)
 Dim intIndex As Integer
 With cmbmyPopup
 .Controls(1).Enabled = Not bolLocked
 .Controls(3).Enabled = Not bolLocked
 For intIndex = 4 To 6
  .Controls(intIndex).Visible = False
 Next
 Select Case strTag
  Case "1": .Controls(4).Visible = True
  Case "2": .Controls(5).Visible = True
  Case "3": .Controls(6).Visible = True
 End Select
 .Controls(7).Enabled = frmForm.CanUndo
 .Controls(8).Enabled = frmForm.CanRedo
 .ShowPopup
 End With
End Sub

Starten sie nun das Userform und spielen sie ein bisschen mit dem Popup. Dabei können sie sich Gedanken über eine wirklich vernünftige Anwendungsmöglichkeit machen.

Sie sehen, es geht immer leichter. Aber damit ihr Selbstwertgefühl nicht ins unermessliche steigt, wenn sie denken, das schlimmste hinter sich zu haben, dann täuschen sie sich.

Dieses Thema hat weitere Beiträge

Symbolleisten (1) - Button einfügen
Symbolleisten (2) - Erzeugen und mehr!
Symbolleisten (3) - Menüleiste (Ab E2000) - Achtung heftig!!!
Symbolleisten (4) - Pop Up (Ab E2000) - Weiter heftig!!!
Symbolleisten (5) - Im VBA Editor - Absolut heftig!!!

Weitere Artikel der Gruppe: Tutorials Aus Excel VBA

Nach oben

ToDo

Google Werbung