Criação de menus simples - JJoão (06/2005)

Deixo-vos aqui algumas rotinas para criação de menus, na barra de menu e no menu de célula.
O código abaixo é parte de um suplemento onde conjugo as rotinas que considero mais úteis, mantendo-as assim sempre à mão. Não irei colocar aqui todas, só as mais simples, que servirão para teste dos itens de menus, considero que a parte importante aqui é a criação dos menus.
As rotinas permitem criar os itens de menu com imagem e texto, analise os parametros das macros abaixo:
Sub CriarItemsCell(xOrdem, xId, xItem, xMacro, xTag, xBeginGroup)
Sub CriarItemsTools(xOrdem, xId, xItem, xMacro, xTag, xBeginGroup)

Estas rotinas são utilizadas pela macro:

Sub CriarMenus()

CriarItemsCell posicao, _ 364, _ "Zona de impressão", _ "set_Area_de_Impressao", _ "jjTools", _ False

Ex. para o menu na barra de menus:

CriarItemsTools posicao,_ 351, _ "2º Item", _ "NomeDaMacro", _ "jjTools", _ False

Para que o menus sejam criados sempre que abrir o livro(Workbook) a macro "Sub CriarMenus() " deve ser chamada através do evento:

PrivateSub Workbook_Open()
    Call CriarMenus 
End Sub 

Para que o menus sejam eliminados sempre que fechar o livro (workbook) a macro "Sub EliminarMenus()" deve ser chamada através do evento :

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

estes eventos estão disponíveis no código de "EsteLivro" (ThisWorkbook).

'
'O código seguinte deve ser colocado num modulo
'
Dim xlMenuBar As CommandBar
Dim jjMenuCell As CommandBarPopup
Dim jjMenuTools As CommandBarPopup
Dim jjMenuBar As CommandBarPopup

'Criar menu celula
Sub Criar_jjMenuCell()
    Set jjMenuCell = Application.CommandBars _
           ("Cell").Controls.Add _
            (Type:=msoControlPopup, _
            before:=1, _
            temporary:=True)
    'definir nome do menu e respectiva tag, podem ser alterados
    'não esquecer que a tag deve ser igual á tag definida na "Sub EliminarMenus()"
    'se alterar aqui terá que alterar lá também
    With jjMenuCell
         .Caption = "JJTools V1.0"
         .Tag = "xpto"
         .BeginGroup = True
    End With
End Sub

'Criar menu na barra de menus
Sub Criar_jjMenuTools()
    'define a barra de menus
    Set xlMenuBar = Application.CommandBars("Worksheet Menu Bar")
    'estado
    xlMenuBar.Visible = True
    'adicionar um novo menu
    Set jjMenuBar = xlMenuBar.Controls.Add _
                    (Type:=msoControlPopup, temporary:=True)
    'definir nome do menu e respectiva tag, podem ser alterados
    'não esquecer que a tag deve ser igual á tag definida na "Sub EliminarMenus()"
    'se alterar aqui terá que alterar lá também
    With jjMenuBar
        .Tag = "jjMenuBar"
        .Caption = "&JJ-Menu"
    End With
    Set jjMenuTools = Application.CommandBars.FindControl _
                    (Type:=msoControlPopup, Tag:="jjMenuBar")
End Sub

'
' Rotina para criar items de menu de celulas,
' itens acessiveis através do clique direito
' dentro da worksheet

Sub CriarItemsCell(xOrdem, xId, xItem, xMacro, xTag, xBeginGroup)
  With jjMenuCell.Controls.Add _
       (Type:=msoControlButton, _
         before:=xOrdem, _
         temporary:=True)
              .Caption = xItem
              .OnAction = xMacro
              .FaceId = xId
              .Tag = xTag
              .BeginGroup = xBeginGroup
  End With
End Sub


'
' Rotina para criar item de menu
'
Sub CriarItemsTools(xOrdem, xId, xItem, xMacro, xTag, xBeginGroup)
    With jjMenuTools.Controls.Add _
       (Type:=msoControlButton, _
         before:=xOrdem, _
         temporary:=True)
              .Caption = xItem
              .OnAction = xMacro
              .FaceId = xId
              .Tag = xTag
              .BeginGroup = xBeginGroup
    End With
End Sub

'
'Rotina principal
'

Sub CriarMenus()

  Dim posicao As Single

  Call EliminarMenus
  Call Criar_jjMenuCell
  Call Criar_jjMenuTools
  posicao = 0
' Criar Items no menu Celula
  posicao = posicao + 1
  CriarItemsCell posicao, 485, "Linhas de Grelha", _
                "jjGridLinesOnOff", "jjTools", True

  posicao = posicao + 1
  CriarItemsCell posicao, 0, "Minusculas", "jjMinusculas", _
                "jjTools", False

  posicao = posicao + 1
  CriarItemsCell posicao, 0, "Maiusculas", "jjMaiusculas", _
                "jjTools", False

  posicao = posicao + 1
  CriarItemsCell posicao, 0, "1ª Maiuscula", "jj1aMaiuscula", _
                "jjTools", False

  posicao = posicao + 1
  CriarItemsCell posicao, 364, "Zona de impressão", _
                "set_Area_de_Impressao", "jjTools", False

  posicao = posicao + 1
  CriarItemsCell posicao, 1, "Formato da celula", "jjGetFormat", _
                "jjTools", False

' Criar Items no menu JJ-Menu
  posicao = 0
  posicao = posicao + 1
  CriarItemsTools posicao, 1695, "1º Item", "NomeDaMacro", _
                "jjTools", False
  posicao = posicao + 1
  CriarItemsTools posicao, 351, "2º Item", "NomeDaMacro", _
                "jjTools", False
  posicao = posicao + 1
  CriarItemsTools posicao, 0, "3ºItem", "NomeDaMacro", _
                "jjTools", False

  Set jjMenuCell = Nothing
  Set jjMenuTools = Nothing
  Set jjMenuBar = Nothing
  Set xlMenuBar = Nothing

End Sub

Sub EliminarMenus()
' Eliminar todos os jjItemsCell
  For Each cItem In Application.CommandBars("cell").Controls
      If cItem.Tag = "xpto" Or cItem.Caption = "" Then cItem.Delete
  Next cItem

' Eliminar o menu personalizado
  For Each cMenu In Application.CommandBars("Worksheet Menu Bar").Controls
      If cMenu.Tag = "jjMenuBar" Then cMenu.Delete
  Next cMenu
End Sub


'---------------------------------------------------------------------------
'Macros usadas pelos itens de menu
'---------------------------------------------------------------------------

'
'Macro de teste
'
Sub NomeDaMacro()
    MsgBox "Teste de macro", vbInformation, "Teste de item de menu"
End Sub

'
'Recolhe o formato da celula corrente
'
Sub jjGetFormat()
    Dim Formato As String
    Dim x As String
    Dim Texto As String
    Texto = "Para copiar o formato, " & _
            " basta selecionar o texto e pressione CTRL+C "
    Formato = ActiveCell.NumberFormatLocal
    x = InputBox(Texto, "Format de " & ActiveCell.Address, Formato)
End Sub

'
'Macro que torna a 1ª letra
'em maiusculas  em todas as palavras
'da zona selecionada
'
Sub jj1aMaiuscula()
    Dim Celula As Range
    Dim xSel As Long, x As Long
    xSel = Selection.Count
    For Each Celula In Selection
        x = x + 1
        stBar x, xSel
        Celula.Value = Application.WorksheetFunction.Proper(Celula.Text)
    Next
End Sub

'
'Macro que torna em maiusculas
'a zona selecionada
'
Sub jjMaiusculas()
    Dim Celula As Range
    Dim xSel As Long, x  As Long
    xSel = Selection.Count
    For Each Celula In Selection
        x = x + 1
        stBar x, xSel
        Celula.Value = UCase(Celula.Text)
    Next
End Sub

'
'Macro que torna em minusculas
'a zona selecionada
'
Sub jjMinusculas()
    Dim Celula  As Range
    Dim xSel As Long, x  As Long
    xSel = Selection.Count
    For Each Celula In Selection
        x = x + 1
        stBar x, xSel
        Celula.Value = LCase(Celula.Text)
    Next
End Sub

'
'Macro que vai dizendo ao utilizador
'em que % se encontra o processo em curso
'
Sub stBar(x1 As Long, x2 As Long)
     'Vai apresentado o evolução da operação em %
    Application.StatusBar = "Processo: " & _
            Format(x1 / x2, "#0%") & _
            " Concluído"

    'No final do processo restaura a barra de estado
    If x1 = x2 Then Application.StatusBar = False
End Sub
'
'Macro inverte o estado das linhas de grelha
'tornando-as visiveis ou não
'
Sub jjGridLinesOnOff()
    ActiveWindow.DisplayGridlines = _
             Not ActiveWindow.DisplayGridlines
End Sub