Thema: Beispiele zum Handling des Zell-Kontextmenüs

ClassModule: Tabelle1

Private Sub Worksheet_Activate()
   Dim oBtn As CommandBarButton
   With Application.CommandBars("Cell")
      Set oBtn = .FindControl(ID:=21)
      oBtn.Enabled = False
   End With
End Sub

Private Sub Worksheet_Deactivate()
   Application.CommandBars("Cell").Reset
End Sub

StandardModule: Modul1

Sub ReadID()
   Dim sMsg As String
   sMsg = "Erstes Element im Zell-Kontextmenü:" & vbLf
   With Application.CommandBars("Cell").Controls(1)
      sMsg = sMsg & "Caption: " & .Caption & vbLf
      sMsg = sMsg & "ID: " & .ID
      MsgBox sMsg
   End With
End Sub

Sub ShowPosition()
   Dim iLeft As Integer, iTop As Integer
   iLeft = Application.InputBox("Linke Position:", , 200, Type:=1)
   iTop = Application.InputBox("Obere Position:", , 200, Type:=1)
   Application.CommandBars("Cell").ShowPopup iLeft, iTop
End Sub

Sub MonthMessage()
   MsgBox "Aufruf kam von " & _
      Application.CommandBars("Months") _
      .Controls(Application.Caller(1)).Caption
End Sub

Sub SetFilter()
   Dim iRow As Integer
   Application.ScreenUpdating = False
   Rows.Hidden = False
   iRow = 1
   Do Until IsEmpty(Cells(iRow, 1))
      If Weekday(Cells(iRow, 1).Value) <> Application.Caller(1) - 2 Then
         Rows(iRow).Hidden = True
      End If
      iRow = iRow + 1
   Loop
   Application.ScreenUpdating = True
End Sub

Sub ResetFilter()
   Rows.Hidden = False
End Sub

Sub SpaltenAus()
   Selection.EntireColumn.Hidden = True
End Sub

Sub SpaltenEin()
   Selection.EntireColumn.Hidden = False
End Sub

Sub InsertValue()
   ActiveCell.Value = Application.CommandBars("RowValues") _
      .Controls(Application.Caller(1)).Caption
End Sub

Sub SelectSheet()
   Worksheets(Application.CommandBars("SheetSelect") _
      .Controls(Application.Caller(1)).Caption).Select
End Sub

Sub DialogShortCutMenus()
   frmKontext.Show
End Sub

Sub ListShortCutMenus()
   Dim oBar As CommandBar
   Dim oCntr As CommandBarControl
   Dim iRow As Integer
   Application.ScreenUpdating = False
   Workbooks.Add
   Range("A1").Value = "Name"
   Range("B1").Value = "Lokaler Name"
   Range("C1").Value = "Eingebaut"
   Range("D1").Value = "Schaltflächen"
   Range("E1").Value = "ID"
   Rows(1).Font.Bold = True
   iRow = 1
   For Each oBar In Application.CommandBars
      If oBar.Type = msoBarTypePopup Then
         iRow = iRow + 1
         Cells(iRow, 1) = oBar.Name
         Cells(iRow, 2) = oBar.NameLocal
         Cells(iRow, 3) = oBar.BuiltIn
         For Each oCntr In oBar.Controls
            Cells(iRow, 4) = oCntr.Caption
            Cells(iRow, 5) = oCntr.ID
            iRow = iRow + 1
         Next oCntr
      End If
   Next oBar
   Columns.AutoFit
   Application.ScreenUpdating = False
End Sub
ClassModule: frmKontext

Private Sub cboControl_Change()
   If cboControl.Text = "" Then Exit Sub
   lblIndexControl.Caption = _
      Application.CommandBars(cboKontext.Text) _
      .Controls(cboControl.Text).ID
End Sub

Private Sub cboKontext_Change()
   Dim objBar As CommandBar
   Dim objCntr As CommandBarControl
   Set objBar = Application.CommandBars(cboKontext.Text)
   lblIndexMenu.Caption = objBar.Index
   lblNameLocal.Caption = objBar.NameLocal
   cboControl.Clear
   For Each objCntr In objBar.Controls
      cboControl.AddItem objCntr.Caption
   Next objCntr
   cboControl.ListIndex = 0
End Sub

Private Sub cmdCancel_Click()
   Unload Me
End Sub

Private Sub cmdOK_Click()
   Unload Me
   Call ListShortCutMenus
End Sub

Private Sub UserForm_Initialize()
   Dim objBar As CommandBar
   For Each objBar In CommandBars
      If objBar.Type = msoBarTypePopup Then
         cboKontext.AddItem objBar.Name
      End If
   Next objBar
   cboKontext.ListIndex = 0
End Sub
ClassModule: Tabelle3

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   If Not Intersect( _
      Target, Range("A1:F16")) Is Nothing Then
      Cancel = True
   End If
End Sub

ClassModule: Tabelle4

Private Sub Worksheet_Activate()
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim iCounter As Integer
   On Error Resume Next
   Application.CommandBars("Months").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "Months", msoBarPopup, False, True)
   For iCounter = 1 To 12
      Set oBtn = oBar.Controls.Add
      With oBtn
         .Caption = Format( _
            DateSerial(1, iCounter, 1), "mmmm")
         .Style = msoButtonCaption
         .OnAction = "MonthMessage"
      End With
   Next iCounter
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("Months").Delete
   On Error GoTo 0
End Sub

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Application.CommandBars("Months").ShowPopup
End Sub

ClassModule: Tabelle5

Private Sub Worksheet_Activate()
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim iCounter As Integer
   On Error Resume Next
   Application.CommandBars("Days").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "Days", msoBarPopup, False, True)
   Set oBtn = oBar.Controls.Add
   With oBtn
      .Caption = "Wochentage:"
      .Style = msoButtonCaption
   End With
   For iCounter = 1 To 7
      Set oBtn = oBar.Controls.Add
      With oBtn
         .Caption = Cells(5 + iCounter, 1).Text
         .Style = msoButtonCaption
         .OnAction = "SetFilter"
         If iCounter = 1 Then
            .BeginGroup = True
         End If
      End With
   Next iCounter
   Set oBtn = oBar.Controls.Add
   With oBtn
      .Caption = "Zurücksetzen"
      .Style = msoButtonCaption
      .OnAction = "ResetFilter"
      .BeginGroup = True
   End With
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("Days").Delete
   On Error GoTo 0
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Application.CommandBars("Days").ShowPopup
End Sub

ClassModule: Tabelle6

Private Sub Worksheet_Activate()
   Dim oBar As CommandBar
   Dim oPopUp As CommandBarPopup
   Dim oCntr As CommandBarControl
   Dim oBtn As CommandBarButton
   On Error Resume Next
   Application.CommandBars("KonNames").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "KonNames", msoBarPopup, False, True)
   Set oPopUp = Application.CommandBars.FindControl(ID:=30023)
   For Each oCntr In oPopUp.Controls
      Set oBtn = oBar.Controls.Add(ID:=oCntr.ID)
   Next oCntr
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("KonNames").Delete
   On Error GoTo 0
End Sub

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Application.CommandBars("KonNames").ShowPopup
End Sub
ClassModule: Tabelle7

Private Sub Worksheet_Activate()
   Dim oBtn As CommandBarButton
   With Application.CommandBars("Cell")
      On Error Resume Next
      .Controls("Spalten aus").Delete
      .Controls("Spalten ein").Delete
      On Error GoTo 0
      Set oBtn = .Controls.Add
      oBtn.Caption = "Spalten aus"
      oBtn.Style = msoButtonCaption
      oBtn.OnAction = "SpaltenAus"
      oBtn.BeginGroup = True
      Set oBtn = .Controls.Add
      oBtn.Caption = "Spalten ein"
      oBtn.Style = msoButtonCaption
      oBtn.OnAction = "SpaltenEin"
   End With
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   With Application.CommandBars("Cell")
      .Controls("Spalten aus").Delete
      .Controls("Spalten ein").Delete
   End With
   On Error GoTo 0
End Sub

ClassModule: Tabelle8

Private Sub Worksheet_Activate()
   Dim oPopUp As CommandBarControl
   Dim oBtn As CommandBarButton
   On Error Resume Next
   Application.CommandBars("Cell") _
      .Controls("Spalten").Delete
   On Error GoTo 0
   Set oPopUp = Application.CommandBars( _
      "Cell").Controls.Add(msoControlPopup)
   With oPopUp
      .Caption = "Spalten"
      .BeginGroup = True
   End With
   Set oBtn = oPopUp.Controls.Add
   With oBtn
      .Caption = "Spalten aus"
      .Style = msoButtonCaption
      .OnAction = "SpaltenAus"
   End With
   Set oBtn = oPopUp.Controls.Add
   With oBtn
      .Caption = "Spalten ein"
      .Style = msoButtonCaption
      .OnAction = "SpaltenEin"
   End With
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("Cell") _
      .Controls("Spalten").Delete
   On Error GoTo 0
End Sub

ClassModule: Tabelle9

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim iCol As Integer
   If WorksheetFunction.CountA( _
      Range(Cells(Target.Row, 3), _
      Cells(Target.Row, 256))) = 0 Then Exit Sub
   Cancel = True
   On Error Resume Next
   Application.CommandBars("RowValues").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "RowValues", msoBarPopup)
   For iCol = 3 To 256
      If Not IsEmpty(Cells(Target.Row, iCol)) Then
         Set oBtn = oBar.Controls.Add
         With oBtn
            .Caption = Cells(Target.Row, iCol).Value
            .Style = msoButtonCaption
            .OnAction = "InsertValue"
         End With
      End If
   Next iCol
   Application.CommandBars("RowValues").ShowPopup
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("RowValues").Delete
   On Error GoTo 0
End Sub
ClassModule: Tabelle10

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim wks As Worksheet
   Cancel = True
   On Error Resume Next
   Application.CommandBars("SheetSelect").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "SheetSelect", msoBarPopup)
   For Each wks In Worksheets
      If wks.Index <> Me.Index Then
         Set oBtn = oBar.Controls.Add
         With oBtn
            .Caption = wks.Name
            .Style = msoButtonCaption
            .OnAction = "SelectSheet"
         End With
      End If
   Next wks
   Application.CommandBars("SheetSelect").ShowPopup
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("SheetSelect").Delete
   On Error GoTo 0
End Sub

Beiträge aus dem Excel-Forum zu den Themen Menue und Context