VBA-Beispiel 144
mail schreiben
mail schreiben

mit VBA CheckBoxen für ein dynamicMenu zur Laufzeit erstellen

Hier wird mit VBA ein dynamicMenu mit CheckBoxen befüllt. Für jede Tabelle eine CheckBox.

Durch "Workbook_SheetActivate" im Modul "DieseArbeitsmappe" wird das dynamicMenu bei jedem Blattwechsel neu erstellt.
Public objRibbon As IRibbonUI

Private Sub OnLoad(ribbon As IRibbonUI) On Error GoTo Fehler Set objRibbon = ribbon Exit Sub Fehler: MsgBox "Fehler in OnLoad", vbCritical, "Fehler!" End Sub
Private Sub dynTabMenu_getContent(control As IRibbonControl, _ ByRef returnedVal) Dim strXML As String, strLabel As String, strTag As String Dim wks As Worksheet Dim bolPressed As Boolean '---------------------------------------- 'Für jede Tabelle eine CheckBox einfügen: '---------------------------------------- On Error GoTo Fehler strXML = _ "<menu xmlns=""http://schemas.microsoft.com/office/2006/01/customui"">" For Each wks In ThisWorkbook.Worksheets strTag = Mask(wks.Name, False) strLabel = Mask(wks.Name, True) bolPressed = IIf(wks.Name = ActiveSheet.Name, True, False) strXML = strXML & "<checkBox id=""chbTab" & wks.Index & """" _ & " label=""" & strLabel & """" _ & " tag=""" & strTag & """" _ & " getPressed=""CheckBox_getPressed""" _ & " onAction=""CheckBox_onAction""/>" & vbLf Next wks strXML = strXML & "</menu>" returnedVal = strXML 'Menü abschicken 'Debug.Print strXML Exit Sub Fehler: MsgBox "Fehler in: dynTabMenu_getContent" & vbLf & _ Err.Description, vbCritical, "Fehler!" End Sub
Private Function Mask(ByVal str As String, _ ByVal bolLabel As Boolean) As String '--------------------------------------------------------- 'Im Tabellennamen erlaubte Sonderzeichen für XML maskieren '--------------------------------------------------------- On Error GoTo Fehler Mask = IIf(bolLabel, Replace(str, "&", "&&"), _ Replace(str, "&", "&")) Mask = Replace(Mask, """", """) Mask = Replace(Mask, "<", "<") Mask = Replace(Mask, ">", ">") Exit Function Fehler: MsgBox "Fehler in: Function Mask" & vbLf & _ Err.Description, vbCritical, "Fehler!" End Function
Private Sub CheckBox_getPressed(control As IRibbonControl, _ ByRef bolPressed) On Error GoTo Fehler bolPressed = IIf(control.Tag = ActiveSheet.Name, True, False) Exit Sub Fehler: MsgBox "Fehler in: CheckBox_getPressed" & vbLf & _ Err.Description, vbCritical, "Fehler!" End Sub
Private Sub CheckBox_onAction(control As IRibbonControl, _ checked As Boolean) '--------------------------------------------------------- 'Die Prozedur wird aufgerufen, wenn der Anwender auf eine 'der eben (per VBA) erstellten CheckBoxen klickt. '--------------------------------------------------------- On Error GoTo Fehler If ThisWorkbook.Worksheets(control.Tag).Visible = True Then ThisWorkbook.Worksheets(control.Tag).Activate Else MsgBox "Tabelle wird nicht angezeigt!", vbInformation, "" End If objRibbon.InvalidateControl (control.ID) Exit Sub Fehler: MsgBox "Upps...", vbCritical, "" End Sub

Download:   vba144.zip