Siehe auch: | FaceId von Schaltflächen | 

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

Symbolleisten (3) - Menüleiste (Ab E2000) - Achtung heftig!!!

Autor: Max Kaffl (Nepumuk) - Erstellt: --      - Letzte Revision: --Gruppenthema: 5 Folgen 1 2 3 4 5 Sie sind in Folge:3
Im dritten Teil der Reihe, werden wird eine neue Menüleiste anlegen.

Dieser Code ist erst ab Excel 2000 lauffähig!

Achtung, im Verlaufe des Programms werden alle sichtbaren Symbolleisten ausgeblendet und einige Popup - Menüs geändert. Sollte ihnen Excel wieder Erwarten dabei abstürzen, dann
"KEINE PANIK" , starten sie das Programm erneut und beenden sie es wieder. Damit werden die Änderungen an den Leisten wieder zurückgenommen.

Da in einer Menüleiste manchmal sehr viele Elemente angelegt werden müssen, werden wir uns einer andern Technik bedienen. Dabei werden alle Informationen an eine weitere Routine übergeben welche die Elemente an- und ihre Eigenschaften festlegt.
Die meisten Argumente werden optional übergeben, da wir nicht immer alle benötigen. Es werden dabei auch Datentypen verwendet, die uns Excel zur Verfügung stellt. Diese können sie aus dem Objektkatalog entnehmen, indem sie nach der entsprechenden Variablen suchen und den Variablentyp aus dem Klassenfenster entnehmen. Dies gilt sowohl für Excelkonstanten (xl...) und Officekonstanten (mso...) als auch für Visual Basic - Konstanten (vb...). Die Benutzung dieser enumerierten Konstanten hat den Vorteil, dass beim Eingeben der Übergabeparameter das Konstantenfenster aufgeht und wir beim editieren so bequem aus der Liste auswählen können.

Nun aber erst mal die Hauptroutinen.

Bitte starten sie diese erst, wenn alle Codeteile vollständig sind. Denn auch dieses mal kommen die notwendigen Routinen, erst nach und nach dazu.


Kopieren sie die folgenden Makros in ein Standardmodul.

Option Explicit
Option Private Module

Private Const MENUBAR_NAME As String = "Privat_Menubar"

Private ccmbCommandBarButton As clsCommandBarButton

Public cmbmyMenubar As CommandBar

Public Sub prcCreateCommandBar()
 Dim cmbCommandBarPopup(1 To 2) As CommandBarPopup
 Dim cmbCommandBarButton As CommandBarButton
 Call prcDeleteCommandBar(False)
 Set cmbmyMenubar = Application.CommandBars.Add(Name:=MENUBAR_NAME, _
 Position:=msoBarTop, MenuBar:=True, Temporary:=True)
 Call prcControlAdd(objParent:=cmbmyMenubar, _
 varControl:=cmbCommandBarPopup(1), enumType:=msoControlPopup, _
 varCaption:="&Datei")
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=18)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=23)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=106)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=3, _
 bolBeginGroup:=True)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=4)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=752, _
 bolBeginGroup:=True)
 Call prcControlAdd(objParent:=cmbmyMenubar, _
 varControl:=cmbCommandBarPopup(1), enumType:=msoControlPopup, _
 varCaption:="&Bearbeiten")
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=128)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=37)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=21, _
 bolBeginGroup:=True)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=19)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=22)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=755)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=1849, _
 bolBeginGroup:=True)
 Call prcControlAdd(objParent:=cmbmyMenubar, _
 varControl:=cmbCommandBarPopup(1), enumType:=msoControlPopup, _
 varCaption:="Date&n")
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=928)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=30031)
 Call prcControlAdd(objParent:=cmbmyMenubar, _
 varControl:=cmbCommandBarPopup(1), enumType:=msoControlPopup, _
 varCaption:="Menü 1")
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), _
 enumType:=msoControlButton, varCaption:="Mein Makro 1", _
 varFaceId:=1, varOnAction:="prcChangeStatus", _
 enumStyle:=msoButtonIconAndCaption, enumState:=msoButtonUp)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), _
 enumType:=msoControlButton, varCaption:="Mein Makro 2", _
 varFaceId:=444, varOnAction:="prcChangeStatus", _
 enumStyle:=msoButtonIconAndCaption, enumState:=msoButtonDown, _
 varTag:="445")
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), _
 varControl:=cmbCommandBarPopup(2), enumType:=msoControlPopup, _
 varCaption:="Menü 2")
 Call prcControlAdd(objParent:=cmbCommandBarPopup(2), _
 enumType:=msoControlButton, varCaption:="Mein Makro 3", _
 varFaceId:=1017, varOnAction:="prcChangeFaceId", _
 enumStyle:=msoButtonIconAndCaption, varTag:="1018")
 Call prcControlAdd(objParent:=cmbCommandBarPopup(2), _
 enumType:=msoControlButton, varCaption:="Mein Makro 4", _
 varFaceId:=70, varOnAction:="prcChangeFaceId", _
 enumStyle:=msoButtonIconAndCaption)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(2), _
 enumType:=msoControlButton, varCaption:="Nicht gedrückt", _
 varFaceId:=276, varOnAction:="prcChangeAll", _
 enumStyle:=msoButtonIconAndCaption, varTag:="59~gedrückt")
 Call prcControlAdd(objParent:=cmbmyMenubar, _
 varControl:=cmbCommandBarPopup(1), enumType:=msoControlPopup, _
 varCaption:="&?")
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=984)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), varId:=1004)
 Call prcControlAdd(objParent:=cmbCommandBarPopup(1), _
 varControl:=cmbCommandBarButton, varId:=927)
 Set ccmbCommandBarButton = New clsCommandBarButton
 Set ccmbCommandBarButton.prpCommandBarButton = cmbCommandBarButton
 With cmbmyMenubar
 .Protection = msoBarNoCustomize + msoBarNoResize _
 + msoBarNoChangeVisible + msoBarNoChangeDock
 .Visible = True
 End With
 Set cmbCommandBarPopup(1) = Nothing
 Set cmbCommandBarPopup(2) = Nothing
 Set cmbCommandBarButton = Nothing
End Sub

Public Sub prcDeleteCommandBar(ByVal bolEnabled As Boolean)
 If Not cmbmyMenubar Is Nothing Then
 cmbmyMenubar.Delete
 Set cmbmyMenubar = Nothing
 Else
 For Each cmbmyMenubar In Application.CommandBars
 If cmbmyMenubar.Name = MENUBAR_NAME Then cmbmyMenubar.Delete
 Next
 End If
 Set ccmbCommandBarButton = Nothing
 Call prcEnableCommandBar(bolEnabled)
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

Nein, das ist nicht kompliziert, sondern nur gewöhnungsbedürftig. Wenn ich die Buttons so angelegt hätte, wie im zweiten Teil, dann wären sie jetzt mit scrollen noch nicht fertig.

Sie sollten sich solche standardisierten Routinen angewöhnen, die erleichtern das Leben ungemein.

Aber das anlegen von Buttons ist nichts neues, was neu ist, sind die Buttons, die wir uns von Excel ausleihen. Wozu sollten wird eine Speicherroutine schreiben, wenn wir sie von Excel frei Haus bekommen. Dazu müssen wir aber die ID - Nummern der einzelnen Elemente kennen.
Ganz oben auf der Seite finden sie einen Link zu einem Makro, mit dem sie sich diese anzeigen lassen können.


Die folgenden Routinen blenden die Originalleisten aus und unsere ein. Zusätzlich werden in den Popup - Menüs die Punkte "Speichern unter" (ID = 748) und "Code anzeigen" (ID = 1561) ausgeblendet. Das Popupmenü der Tabellenreiter ("Ply") wird komplett ausgeblendet. Alle anderen Popups bleiben erhalten.

Zum Schutz unserer Menübar wird das Menü "Anpassen" ("Toolbar List") ausgeblendet und der Doppelklick unterdrückt.

Mit einem kleinen Trick, können wir auch eine Eigenschaft der Commandbars, aus Excel XP und höher, in einem Code für Excel 2000 unterbringen. Dazu übergeben wir das Commandbar - Auflistungsobjekt an eine Objektvariable bei welcher die Eigenschaft ("DisableCustomize") geändert wird. Würden wir das auf das Commandbar - Objekt anwenden, würde in Excel 2000 ein Kompilierungsfehler entstehen, da das Objekt in dieser Version diese Eigenschaft nicht hat. Eine, als Objekt deklarierte Variable, hat keine spezifischen Eigenschaften und akzeptiert sie darum. Durch eine abfrage der Version müssen wir nur die Ausführung der Anweisung steuern.

Die Routine zum aus- und einschalten von Menüpunkten ist wieder eine Standardroutine. Sie wird ihnen, im weiteren Verlauf der Reihe, sicher noch mal unterkommen.

Fügen sie die Makros unter dem bisherigen Code ein.

Public Sub prcEnableCommandBar(ByVal bolEnabled As Boolean)
 Dim cmbCommandBar As CommandBar
 Dim objCommandBars As Object
 For Each cmbCommandBar In Application.CommandBars
 With cmbCommandBar
 If .Name <> MENUBAR_NAME Then
 If .Type <> msoBarTypePopup Then
  .Enabled = bolEnabled
 Else
  Call prcEnableCommandBarControl( _
  bolEnabled:=bolEnabled, bolVisible:=bolEnabled, _
  cmbCommandBar:=cmbCommandBar, varId:=748)
  Call prcEnableCommandBarControl( _
  bolEnabled:=bolEnabled, bolVisible:=bolEnabled, _
  cmbCommandBar:=cmbCommandBar, varId:=1561)
 End If
 Else
 .Enabled = Not bolEnabled
 .Visible = Not bolEnabled
 End If
 End With
 Next
 With Application
 .EnableCancelKey = IIf(bolEnabled, xlInterrupt, xlDisabled)
 If Val(.Version) > 9 Then
 Set objCommandBars = .CommandBars
 objCommandBars.DisableCustomize = Not bolEnabled
 Set objCommandBars = Nothing
 End If
 .CommandBars("Toolbar List").Enabled = bolEnabled
 .CommandBars("Ply").Enabled = bolEnabled
 .OnDoubleClick = IIf(bolEnabled, "", "prcDoNothing")
 End With
End Sub

Private Sub prcEnableCommandBarControl( _
 ByVal bolEnabled As Boolean, _
 ByVal bolVisible As Boolean, _
 ByRef cmbCommandBar As CommandBar, _
 Optional ByVal enumType As MsoControlType, _
 Optional ByVal varId As Variant, _
 Optional ByVal varTag As Variant, _
 Optional ByVal bolVisibleControl As Boolean = False, _
 Optional ByVal bolRecursive As Boolean = True)
 Dim cmbCommandBarControl As CommandBarControl
 Dim bolUnprotect As Boolean
 Select Case IIf(enumType, 1, 0) & IIf(IsMissing(varId), 0, 1) & _
 IIf(IsMissing(varTag), 0, 1)
 Case "001": Set cmbCommandBarControl = cmbCommandBar.FindControl( _
 Tag:=varTag, Visible:=bolVisibleControl, _
 Recursive:=bolRecursive)
 Case "010": Set cmbCommandBarControl = cmbCommandBar.FindControl( _
 ID:=varId, Visible:=bolVisibleControl, Recursive:=bolRecursive)
 Case "011": Set cmbCommandBarControl = cmbCommandBar.FindControl( _
 ID:=varId, Tag:=varTag, Visible:=bolVisibleControl, _
 Recursive:=bolRecursive)
 Case "100": Set cmbCommandBarControl = cmbCommandBar.FindControl( _
 Type:=enumType, Visible:=bolVisibleControl, _
 Recursive:=bolRecursive)
 Case "101": Set cmbCommandBarControl = cmbCommandBar.FindControl( _
 Type:=enumType, Tag:=varTag, Visible:=bolVisibleControl, _
 Recursive:=bolRecursive)
 Case "110": Set cmbCommandBarControl = cmbCommandBar.FindControl( _
 Type:=enumType, ID:=varId, Visible:=bolVisibleControl, _
 Recursive:=bolRecursive)
 Case "111": Set cmbCommandBarControl = cmbCommandBar.FindControl( _
 Type:=enumType, ID:=varId, Tag:=varTag, _
 Visible:=bolVisibleControl, Recursive:=bolRecursive)
 End Select
 If Not cmbCommandBarControl Is Nothing Then
 If cmbCommandBar.Protection And msoBarNoCustomize Then
 cmbCommandBar.Protection = cmbCommandBar.Protection - _
 msoBarNoCustomize
 bolUnprotect = True
 End If
 With cmbCommandBarControl
 .Enabled = bolEnabled
 .Visible = bolVisible
 End With
 If bolUnprotect Then cmbCommandBar.Protection = _
 cmbCommandBar.Protection + msoBarNoCustomize
 End If
End Sub

Private Sub prcDoNothing()
 ' This procedur do nothing
End Sub

Die nun folgenden Makros, sind kleine Spielereien zum Thema Icon und Caption von Commandbarbuttons. Die Buttons ohne Icon zeigen dabei, im Zustand "gedrückt", ein Häkchen an.

Auch diese kommen in das Standardmodul.

Private Sub prcChangeStatus()
 Dim strNewTag As String
 With Application.CommandBars.ActionControl
 .State = IIf(.State = msoButtonUp, msoButtonDown, msoButtonUp)
 If Trim$(.Tag) <> "" Then
 strNewTag = CStr(.FaceId)
 .FaceId = CLng(.Tag)
 .Tag = strNewTag
 End If
 End With
End Sub

Private Sub prcChangeFaceId()
 Dim lngOldFaceId As Long
 With Application.CommandBars.ActionControl
 lngOldFaceId = .FaceId
 If Trim$(.Tag) <> "" Then
 .FaceId = CLng(.Tag)
 .Tag = CStr(lngOldFaceId)
 Else
 lngOldFaceId = lngOldFaceId + 1
 If lngOldFaceId = 80 Then lngOldFaceId = 70
 .FaceId = lngOldFaceId
 End If
 End With
End Sub

Private Sub prcChangeAll()
 Dim strNewTag As String
 With Application.CommandBars.ActionControl
 strNewTag = CStr(.FaceId) & "~" & .Caption
 .FaceId = CLng(Split(.Tag, "~")(0))
 .Caption = Split(.Tag, "~")(1)
 .Tag = strNewTag
 End With
End Sub

Da wir als Programmierer uns einen kleinen Notausgang offen halten, damit wir in der Mappe richtig arbeiten können, legen wir eine versteckte Funktion auf einen der Buttons. Nämlich dem Info - Button im Hilfemenü. Dazu benötigen wir ein Klassenmodul mit dem Namen "clsCommandBarButton". Dieses legen sie über das Menü Einfügen - Klassenmodul an. Den Namen können sie im Eigenschaftsfenster ändern. Die Zuweisung des Buttons an das Klassenmodul, erfolgt aus der Hauptroutine heraus über eine Property Set - Prozedur.

Der folgende Code kommt in dieses Klassenmodul.

Option Explicit

Private Declare Function GetKeyboardState Lib "user32.dll" ( _
 kbArray As KeyboardBytes) As Long

Private Type KeyboardBytes
 kbByte(0 To 255) As Byte
End Type

Private Const VK_SHIFT = &H10
Private Const VK_CONTROL = &H11

Private WithEvents mcmdCommandBarButton As CommandBarButton

Private Sub mcmdCommandBarButton_Click(ByVal Ctrl As CommandBarButton, _
 CancelDefault As Boolean)
 Dim udtkbArray As KeyboardBytes
 Call GetKeyboardState(udtkbArray)
 If udtkbArray.kbByte(VK_SHIFT) > 1 And _
 udtkbArray.kbByte(VK_CONTROL) > 1 Then
' mit Shifttaste und Controltaste
 Call prcDeleteCommandBar(True)
 ElseIf udtkbArray.kbByte(VK_SHIFT) > 1 Then
' mit Shifttaste
 ElseIf udtkbArray.kbByte(VK_CONTROL) > 1 Then
' mit Controltaste
 Else
' ohne Taste
 End If
End Sub

Public Property Set prpCommandBarButton( _
 ByVal ccmdCommandBarButton As CommandBarButton)
 Set mcmdCommandBarButton = ccmdCommandBarButton
End Property

Als Ereignis wird der Klick auf den Button ausgewertet. Dabei wird über die API - Funktion " GetKeyboardState" der Status der Tastatur ausgelesen und die Shift- und Control- Taste ausgewertet. Sind diese beiden Tasten beim Klick auf den Button gedrückt, werden die normalen Symbolleisten wiederhergestellt. Auf diese Art lassen sich mit jeden Button vier verschiedene Routinen starten. Wenn der Button zusätzlich eine OnAction - Eigenschaft hat, wird deren Makro immer mit ausgelöst.


Nun noch die Routinen, welche unsere Leiste aufrufen, sowie beim Mappenwechsel ein- und ausblenden. Diese gehören, wie sie sicher wissen, in das Klassenmodul der Mappe.

Option Explicit

Private Sub Workbook_Activate()
 If Not cmbmyMenubar Is Nothing Then
 Application.ScreenUpdating = False
 Call prcEnableCommandBar(False)
 Application.ScreenUpdating = True
 End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
 With ThisWorkbook
 If Not .Saved Then
 Select Case MsgBox("Änderungen speichern?", 35, "Abfrage")
 Case 2
  Cancel = True
  Exit Sub
 Case 6: .Save
 Case 7: .Saved = True
 End Select
 End If
 End With
 Call prcDeleteCommandBar(True)
End Sub

Private Sub Workbook_Deactivate()
 If Not cmbmyMenubar Is Nothing Then
 Application.ScreenUpdating = False
 Call prcEnableCommandBar(True)
 Application.ScreenUpdating = True
 End If
End Sub

Private Sub Workbook_Open()
 Application.ScreenUpdating = False
 Call prcCreateCommandBar
 Application.ScreenUpdating = True
End Sub

Jetzt die Mappe speichern, schließen und wieder öffnen. Toll, oder?

Diesmal war es wirklich gar nicht so einfach. Beim nächsten mal werden sie das Popupmenü kennen lernen. Das wird dann eine richtige Entspannungsübung.



Weitere Artikel der Gruppe: Tutorials Aus Excel VBA
Nach oben
ToDo
Google Werbung