Vimos até o momento como personalizar a nova interface do Excel. Neste tópico e no próximo quebrarei o gelo um pouco retornando aos antigos menus do Excel os quais não são causas completamente perdidas.

Seria realmente horrível, para não dizer “pesadelo”, acordar e descobrir que todo o sistema criado em VBA não funciona na nova versão do Office.

Embora exista a compatibilidade, a realidade de nossa barra de ferramenta em relação à nova interface é outra:

Figura 6‑1 Barras antigas de ferramentas adicionadas à guia “Suplementos”

Quando adicionamos as barras de comando no estilo antigo, as mesmas são adicionadas em uma nova guia chamada “Suplementos” conforme mostra a figura acima. Teremos uma exceção a tal regra para os popups, como veremos no tópico seguinte a este.

Note que embora seja denominada de “Suplementos” o arquivo não necessariamente precisa ser um suplemento.

No exemplo acima, o menu é dinâmico e é modificado conforme selecionamos diferentes planilhas. Vejamos como criar tal suplemento. O código abaixo acompanha as explicações:

Adicione o código a seguir no VBE da pasta de trabalho:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call wsMenuDel
End Sub

Private Sub Workbook_Open()
    Call wsMenus
End Sub
Adicione um módulo de classe onde inseriremos o código como segue:
Option Explicit

'Declara os objetos que serao monitorados
Public WithEvents appXL As Application
Public WithEvents drop  As Office.CommandBarComboBox

'Rotina para monitar o ativamento de planilha
Private Sub appXL_SheetActivate(ByVal Sh As Object)
    Dim btnDropDown     As Object
    Dim ws              As Worksheet
    Dim wb              As Workbook
    Dim i               As Long

'   Define o objeto wb como sendo a pasta ativa
    Set wb = ActiveWorkbook

'   Se a pasta ativa nao for a "Tópico 13.xls", entao
'   sair da rotina
    If Not wb.Name = "Tópico6.xls" Then Exit Sub

'   Define o objeto btnDropDown como sendo a combobox na
'   barra de comando CMDBARNOME. O controle é encontrado
'   através da etiqueta (Tag)
    Set btnDropDown = CommandBars(CMDBARNOME).FindControl _
        (Type:=msoControlDropdown, Tag:="Lista")
   
'   Limpa a combobox
    btnDropDown.Clear

'   Para cada planilha na pasta de trabalho
    For Each ws In Sh.Parent.Sheets
'       Adicionar o nome da planilha a combobox
        btnDropDown.AddItem ws.Name
    Next

'   Define o item ativa na combobox
    For i = 1 To btnDropDown.ListCount
        If btnDropDown.List(i) = Sh.Name Then _
        btnDropDown.ListIndex = i: Exit For
    Next

'   Chama a rotina de mudanca na combobox
'   Observe que nao somente estamos monitorando o aplicativo
'   como também a combobox
    Call drop_Change(btnDropDown)

End Sub

Private Sub appXL_WorkbookActivate(ByVal wb As Workbook)

Dim btnDropDown     As Object

Set btnDropDown = CommandBars(CMDBARNOME).FindControl _
    (Type:=msoControlDropdown, Tag:="Lista")

'   Se a pasta de trabalho atual  for a "Tópico 13.xls"
    If wb.Name = "Tópico6.xls" Then
'       Entao, ativar a combobox e
        btnDropDown.Enabled = True
'       chamar a rotina de ativacao de planilha
        appXL_SheetActivate wb.ActiveSheet
    Else:
'       Se nao for, entao remover o menu
        Call mnuRemover
'       E desabilitar a combobox
        btnDropDown.Enabled = False
    End If
End Sub

Public Sub setDrop(box As Office.CommandBarComboBox)
'   Define a combobox como sendo a "box"
'   Esta ativacao é feita quando a rotina de criacao
'   do menu é rodada. A linha no módulo que faz isso é
'   "cboBox.setDrop btnDropDown"
    Set drop = box
End Sub

Private Sub drop_Change(ByVal Ctrl As Office.CommandBarComboBox)
    Dim macro As String
   
'   Aqui, chamo de "macro" apenas para me lembrar que ao selecionar
'   uma planilha da lista na combobox uma macro deve ser rodada.
'   A "macro" é o texto contido na combobox
    macro = Ctrl.Text
   
'   Seleciona o caso "macro"
'   Para cada caso, uma rotina diferente é chamada
    Select Case UCase(macro)
        Case "FORNECEDORES"
            Call mnuFornecedores
        Case "CLIENTES"
            Call mnuClientes
        Case "CONTAS"
            Call mnuContas
        Case Else
            Call mnuRemover
    End Select
End Sub

Finalmente, adicione um novo módulo (observe que o módulo utiliza a classe e portanto o nome da classe deve coincidir) onde acrescentaremos o código abaixo:

Option Explicit
'Constante públicas utilizadas no códiog
Public Const CMDBARNOME         As String = "MENU CAMALEAO"
Public Const MENUFORNECEDORES   As String = "Fornecedores"
Public Const MENUCLIENTES       As String = "Clientes"
Public Const MENUCONTA          As String = "Contas"

'Dimensiona os objetos contendo os eventos como sendo a classe onde
'onde eventos foram definidos
'appExcel refere-se aos eventos do aplicativo (Excel)
Dim appExcel    As New Classe1
' cboBox refere-se aos eventos da combobox
Dim cboBox      As New Classe1

Sub wsMenus()
'   Dimensiona os objetos
    Dim cmdBar          As CommandBar
    Dim btn             As CommandBarButton
    Dim btnDropDown     As Object

'   Remove a barra de comando caso ela já exista
    Call wsMenuDel

'   Cria a nova barra de comando
    Set cmdBar = CommandBars.Add(CMDBARNOME, msoBarFloating)
        cmdBar.Width = 150

'   Adiciona o menu dropdown
    Set btnDropDown = cmdBar.Controls.Add(Type:=msoControlDropdown)
        With btnDropDown
'           A Tag (etiquetq) é utilizada na classe
            .Tag = "Lista"
'           Acao a ser executada
            .OnAction = "selPlanilha"
            .Width = 150
        End With
   
'   Adiciona um botao de ajuda a barra de comando
    Set btn = cmdBar.Controls.Add(Type:=msoControlButton)
        With btn
            .Caption = "Ajuda"
            .OnAction = "ajuda"
            .Style = msoButtonIconAndCaption
            .FaceId = 984
        End With
   
    'Define os eventos do aplicativo que serão monitorados
    Set appExcel.appXL = Application
   
    'Define a combobox que deve ser monitorada pela Classe1
    cboBox.setDrop btnDropDown

    With cmdBar
        .Visible = True
        .Protection = msoBarNoChangeDock + msoBarNoResize
    End With
End Sub

Sub wsMenuDel()
On Error Resume Next
Application.CommandBars(CMDBARNOME).Delete
End Sub

Sub selPlanilha()
Dim btnDropDown As Object
On Error Resume Next
Set btnDropDown = CommandBars.FindControl(Type:=msoControlDropdown, Tag:="Lista")
    ActiveWorkbook.Sheets(btnDropDown.Text).Activate
End Sub

Sub mnuFornecedores()
    Dim cmdBar          As CommandBar
    Dim menu            As CommandBarPopup
    Dim btn             As CommandBarButton

    Set cmdBar = CommandBars(CMDBARNOME)
   
    On Error Resume Next
    cmdBar.Controls(MENUCONTA).Delete
    cmdBar.Controls(MENUCLIENTES).Delete
    cmdBar.Controls(MENUFORNECEDORES).Delete

    Set menu = cmdBar.Controls.Add(Type:=msoControlPopup, BEFORE:=2)
        menu.Caption = MENUFORNECEDORES
   
    Set btn = menu.Controls.Add(Type:=msoControlButton)
    btn.Caption = "Registrar Fornecedor"
   
    Set btn = menu.Controls.Add(Type:=msoControlButton)
    btn.Caption = "Situação cadastral"

End Sub

Sub mnuClientes()
    Dim cmdBar          As CommandBar
    Dim menu            As CommandBarPopup
    Dim btn             As CommandBarButton

    Set cmdBar = CommandBars(CMDBARNOME)
   
    On Error Resume Next
    cmdBar.Controls(MENUCONTA).Delete
    cmdBar.Controls(MENUCLIENTES).Delete
    cmdBar.Controls(MENUFORNECEDORES).Delete
   
    Set menu = cmdBar.Controls.Add(Type:=msoControlPopup, BEFORE:=2)
        menu.Caption = MENUCLIENTES
   
    Set btn = menu.Controls.Add(Type:=msoControlButton)
    btn.Caption = "Registrar Cliente"
   
    Set btn = menu.Controls.Add(Type:=msoControlButton)
    btn.Caption = "Situação pgtos"

End Sub

Sub mnuRemover()
    Dim cmdBar          As CommandBar

    Set cmdBar = CommandBars(CMDBARNOME)
   
'   Remove todos os botoes
    On Error Resume Next
    cmdBar.Controls(MENUCONTA).Delete
    cmdBar.Controls(MENUCLIENTES).Delete
    cmdBar.Controls(MENUFORNECEDORES).Delete
End Sub

Sub ajuda()
   ActiveWorkbook.FollowHyperlink "http://www.wordpower.com.br", NewWindow:=True, AddHistory:=True
End Sub