Systém ponúk v Exceli

Aplikácie kancelárskeho balíku OFFICE (okrem Outlook-u) poskytujú spoločné rozhranie Dialógové okno "Prispôsobiť", ktoré nám umožňuje vykonávať zmeny v hlavnej ponuke alebo aj paneloch nástrojov. Tieto zmeny zahrňujú pridanie, presunutie, obnovenie jednotlivých položiek menu ako aj tlačidiel (ikon) na paneloch nástrojov. Modifikovať ponuky a panely nástrojov možno však aj pomocou kódu VBA.Tento článok sa bude zaobarať modifikáciou spomínaných panelov prostredníctvom kódu vo VBA, lebo i keď meniť a prispôsobovať panely je rýchlejšie a pohodlnejšie pomocou dialógového okna "Prispôsobiť", niektoré zmeny nie je možné vykonať pomocou dialógového okna. Na nasledujúcom obrázku je zobrazený Panel s ponukami pre pracovný hárok = Worksheet Menu Bar.



Na paneloch s ponukami vidíme jednotlivé ponuky. Na obrázku nižšie je zobrazená jedna z ponúk - Vložiť a pod ponukou v roletovom okne sú položky ponuky.



Každá položka ponuky môže mať ešte submenu. Na obrázku nižšie, trojuholníček ukazuje na submenu.



Program vo VBA SystémPonúk vylistuje na hárku (liste) Excelu celú štruktúru systému ponúk. Na jeden hárok Excelu vylistuje všetky položky jednej ponuky a ak existuje submenu vylistuje aj submenu, ako to ukazuje posledný obrázok. Ak v zošite Excelu nie je dosť hárkov pridá hárky podľa predtým spočítaného počtu ponúk.

Sub SystémPonúk()
' Vylistuje všetky položy panelu  s ponukami pre pracovný hárok
' ako aj položky každého menu
Application.ScreenUpdating = False
Application.StatusBar = Formula & "Čakajte, bude to chvíľu trvať..."
'  V stavovom riadku vidíme nápis  Čakajte ...
zac = Timer
c1 = Application.CommandBars(1).Controls.Count
' zistí počet ponúk v hlavnom menu
While Sheets.Count < c1
  Sheets.Add ' pridá potrebný počet hárkov (listov)
Wend
For i = 1 To c1
  c3 = 0
  Worksheets(i).Activate
  Set toto = Application.CommandBars(1).Controls(i)
  Cells(1, 1) = toto.Caption ' názov menu
  Cells(1, 2) = toto.ID ' ID určuje vstavanú akciu
  Cells(1, 3) = toto.Index 'poradové číslo
  Range(Cells(1, 1), Cells(1, 3)).Select
    With Range(Cells(1, 1), Cells(1, 3))
      .Font.Bold = True
      .Font.ColorIndex = 2
    With Selection.Interior
      .ColorIndex = 5
    End With
    End With
  c2 = toto.CommandBar.Controls.Count
  For j = 1 To c2
    c3 = 0
    Cells(j + 1, 1) = toto.Controls(j).Caption
    Cells(j + 1, 2) = toto.Controls(j).ID
    Cells(j + 1, 3) = toto.Controls(j).Index
    Range(Cells(1, 1), Cells(1, 3)).Select
      With Range(Cells(j + 1, 1), Cells(j + 1, 3))
        .Font.Bold = False
        .Font.Name = "Arial "
        .Font.Size = 10
        .Font.ColorIndex = 23
      End With
    On Error Resume Next ' príkaz On Error ... musíme zadať,
    ' lebo nie každá  položka menu má ešte submenu
    c3 = toto.Controls(j).Controls.Count
    If c3 <> 0 Then
      For k = 1 To c3
        Cells(j + 1, 3 + k) = toto.Controls(j).Controls(k).Caption
        Range(Cells(j + 1, 3 + k), Cells(j + 1, 3 + k)).Select
        Selection.Font.Size = 10
        Selection.Font.Bold = False
        Selection.Font.ColorIndex = 22
      Next k
    End If
  Next j
  Columns("A:V").EntireColumn.AutoFit
  Next i
  kon = Timer
  cas = kon - zac
  ' MsgBox "Čas =  " & cas & " sekúnd "
  ' Odstráňte znak('),ak chcete zistiť čas vykonania úlohy
  Application.StatusBar = False
  Application.ScreenUpdating = True
End Sub

Sub symb()
Set symbItem = CommandBars ("Worksheet Menu Bar").Controls("Vložiť") _
    .Controls.Add(Type:=msoControlButton, Before:=3)
With symbItem
    .Caption = "S&symbol"
    .OnAction = "SymbVlož"
    ' Pri kliknutí na položku
    ' spustí sa program SymbVlož
End With
End Sub
Sub SymbVlož()
  sym = Shell("C:\WINDOWS\CHARMAP.EXE", 1)
End Sub

Stránka je v súlade s aktuálnymi normami.