Menu

VBA - Criação de um UserForm em um módulo de Classe

USFRITBR
Faça uma pergunta

Introdução

Como criar um formulário de usuário (UserForm) com um certo número de testes dinâmicos e poder verificar se eles reagem a certos eventos?

Para conseguir fazer isto, nós poderíamos simplesmente criar um Userform e um módulo de classe. Ao atribuir à classe os controles criados dinamicamente no userform, nós podemos fazê-los "reagir".

O objetivo é obter um único módulo no final e simplificar o processo de chamada, limitado a apenas duas ou três linhas de código.

Método usado

Vamos criar o UserForm e seu módulo diretamente como um objeto, e isso, graças ao nosso Módulo de classe.

Esta discussão (em francês) vai te dar o caminho e explicar os diferentes aspectos e soluções. Não é preciso repetir aqui o que foi feito nesta discussão.

Necessidade

Nas Opções do Excel, já devemos ter marcado Confiar no acesso ao modelo de objeto do projeto do VBA. Para isso, vá em Opções > Centro de Gerenciamento de Confiança > Configurações de macro. Quanto ao código também é preciso marcar duas referências:

- Microsoft Forms 2.0 Object Library.
- Microsoft Visual Basic For Applications Extensibility 5.3.

Para fazê-lo, no editor VBA, abra o menu Ferramentas > Referências.

Os códigos

Vamos nos contentar em criar um UserForm com dois botões. Estes dois botões deverão reagir ao clique e retornar, no código de chamada, a sua legenda.

O módulo de classe

1- Crie um módulo de classe em seu projeto VBA.
2- Nomeie o "PrimeiroExemplo" (propriedade Nome da Classe)
3- insira este código: 

Opção Explicit 
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'É necessário marcar as duas referências que seguem (Menu Ferramentas/Referências)
    'Microsoft Forms 2.0 Object Library
    'Microsoft Visual Basic For Applications Extensibility 5.3
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Public maForm As Object                                        'UserForm
Public WithEvents Botão As MSForms.CommandButton              'Botão
Public Dictionnary As Object                                          'Objeto Dictionnary = nossa coleção de objetos 

Private Nome As String        'Nome => permite a construção e a desconstrução do UserForm 

Private Sub Class_Initialize()
'construtor da classe 
   Set Dico = CreateObject("Scripting.dictionary")
End Sub

Public Function Value()
'O método Value da nossa Classe permite a construção do UserForm
'e o retorno do valor 
    NewUsf "Meu primeiro UserForm"  'criação do UserForm
    NewBouton "toto", "TOTO", 120, 30, 5, 5  'criação do botão TOTO
    NewBouton "titi", "TITI", 120, 30, 5, 35  'criação do botão TITI
    maForm.Show   'exibição do UserForm
    On Error GoTo fin
    Value = meuForm.Tag  'atribuímos a nossa função o valor contido no Tag do UserForm
    Unload meuForm
    Exit Function
fim:
End Function

Private Sub NewUsf(minhaLegenda As String)
'procedimento de criação do UserForm
    Set meuForm = ThisWorkbook.VBProject.VBComponents.Add(3) 
    Nome = meuForm.Name
    VBA.UserForms.Add (Nome)
    Set meuForm = UserForms(UserForms.Count - 1)
    With meuForm
      .Caption = minhaLegenda 
      .Width = 150
      .Height = 100
    End With
End Sub

Public Sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double)
'Procedimento de criação de um botão de controle 
Dim Obj
    Set Obj = meuForm.Controls.Add("forms.CommandButton.1")
    If Obj = True Then Exit Sub
    Dim cls As New PrimeiroExemplo
    Set cls.meuForm = meuForm
    Set cls.Bouton = Obj
    With cls.Bouton
        .Name = Name
        .Caption = Caption
        .Move Left, Top, Width, Height
    End With
    Dico.Add Name, cls
    Set cls = Nothing
End Sub

Private Sub Bouton_Click()
'procedimento de evento do clique no botão 
   meuForm.Tag = Botão.Legenda
   meuForm.Hide
End Sub

Private Sub Class_Terminate()
'destruidor da classe 
   Dim VBComp As VBComponent
   Set Dico = Nothing            'suprime todas as instâncias de nossa classe > todos os botões 
   If Nom <> "" Then             'trata-se do UserForm (única instância com uma propriedade "Nome" preenchida)
      Set VBComp = ThisWorkbook.VBProject.VBComponents(Nome) 'fixa-se o alvo 
      ThisWorkbook.VBProject.VBComponents.Remove VBComp     'suprime-se o alvo
   End If
End Sub

O procedimento do código de chamada

É bem simplificado ...
Graças ao seu módulo de classe você obtém um UserForm E um método Value. Este método é devolvido muito simplesmente para onde você quiser, usando o código de chamada: 
Sub test()
Dim MyForm As New PrimeiroExemplo
MsgBox MyForm.Value
Set MyForm = Nothing
End Sub

O interesse aqui é óbvio. O usuário do nosso UserForm ou de nossa Classe não se questiona. Ele sabe o que fazer com um código tipo meuForm.Value. Nada mais fácil do que colocar este resultado numa Célula, em uma Caixa de Texto, etc.

Exemplo mais complexo: o jogo do Campo Minado

Neste exemplo, os botões serão criados aleatoriamente, em um quadro (Frame) usado como recipiente dentro do nosso Userform.
Note que aqui, como não há retorno de valor, não vamos criar um método "Value" para a nossa Classe.

O código de chamada

A ser colocado em um módulo padrão: 
Sub Usf_Desarmar()
  Dim MyForm As New cDesarmar
  MyForm.Show 0 , False
End Sub

Os parâmetros deste UserForm são:
- Primeiro parâmetro [obrigatório]: 0, 1 ou 2 representa a dificuldade (%idade das minas)
- Segundo parâmetro [Facultativo]: True (Verdadeiro) ou False (Falso) = Modo de fraude ativado ou não

O Módulo de Classe

1- Crie um módulo de classe em seu projeto VBA.
2- Nomeie o cDesarmador (propriedade Nome da classe)
3- Insira este código: 
Opção Explicit
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'É preciso marcar as duas referências que seguem (Menu Ferramentas/Referências)
    'Microsoft Forms 2.0 Object Library
    'Microsoft Visual Basic For Applications Extensibility 5.3
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

'Variáveis publicas
Public meuForm As Object                                         'Userform
Public Fram As MSForms.Frame                                    'Frame = com botões
Public Dico As Object                                           'Objet dictionary
Public DicoParent As Object                                     'Objet dictionary
Public Mina As Boolean                                         'Propriedade Mina se True = botão trucado
Public Descoberta  As Boolean                                    'Propriedade Descoberta se True = "terreno(botão) desarmado"
'variáveis privadas 
Private Nom As String                                           'Nome => permite a construção e a desconstrução do UserForm
Private cVizinho() As cDesarmador          'propriedade em forma de tabela que lista os  botões vizinhos 
'variáveis públicas "de eventos" 
Public WithEvents Bouton As MSForms.CommandButton               'Botão
'constantes
Private Const LARG_BTN As Byte = 18                             'tamanho dos botões 
Private Const MIN_LIGN As Byte = 7                                 'mínimo de linhas 
Private Const MAX_LIGN As Byte = 30 - MIN_LIGN                  'máximo de linhas
Private Const MIN_COL As Byte = 7                               'mínimo de colunas
Private Const MAX_COL As Byte = 40 - MIN_COL                    'máximo de colunas
Private Const POURCENT_SIMPLE As Byte = 10               '%idade das minas em modo fácil
Private Const POURCENT_MEDIUM As Byte = 2 * POURCENT_SIMPLE     '%idade das minas em modo médio 
Private Const POURCENT_HARD As Byte = 3 * POURCENT_SIMPLE       '%idade das minas em modo difícil  
Private Const COL_MINE As Long = &H188B0                       'cor dos botões minados (para desvelá-los)
Private Const COL_BOUTON As Long = &H8000000F                  'cor dos botões
Private Const COL_MINE_POSSIBLE As Long = &HFFFFFF             'cor se botão possivelmente minado (botão exibe?) > dúvida
Private Const COL_MINE_PROB As Long = &H8080FF                 'cor se botão provavelmente minado (botão exibe!) => atenção perigo 

Property Get Vizinho() As cDesrmador()                           'propriedade de tipo tabela 
'propriedade Vizinhos em Leitura
   Vizinho = cVizinho
End Property

Property Let Vizinhos(ByRef novoVizinho() As cDesrmador)
'propriedade Vizinho em Escrita 
   cVizinho = novosVizinhos
End Property

Private Sub Class_Initialize()
'construtor da classe cDesarmador 
   Set Dictionnary = CreateObject("Scripting.dictionary")
End Sub

Public Sub Show(ByRef Difficult As Long, Optional ModeTriche As Boolean = False)
'Método Show: permite a exibição do UserForm
   On Error GoTo ErroParâmetrosMacros        'Verificação se "acesso aprovado para o modelo objeto do projeto VBA" é marcado nas opções do Excel
   With ThisWorkbook.VBProject: End With
   Dim Lign As Long, Col As Long, NbLinhas As Long, NbColunas As Long
   Dim NbMinas As Long, MineAdress() As String, CptMine As Long
   Randomize Timer                             'inicialização geradora de números aleatórios 
   NbLinhas = Int(MAX_LINHAS * Rnd) + MIN_LINHAS   'Número de linhas de botões
   NbColunas = Int(MAX_COL * Rnd) + MIN_COL   'Número de colunas de botões
   Select Case Difficult                       'Número de Minas de acordo com a dificuldade escolhida 
      Case 0: Difficult = POURCENT_SIMPLE
      Case 1: Difficult = POURCENT_MEDIUM
      Case 2: Difficult = POURCENT_HARD
      Case Else: Exit Sub
   End Select
   NbMinas = (NbLinhas * NbColunas) * Difficult \ 100
   ReDim MineAdress(NbMinas)
   For CptMine = 1 To NbMinas                 'coordenadas das Minas: Col-Linhas
      MineAdress(CptMine) = Int(NbColunas * Rnd) + 1 & "-" & Int(NbLinhas * Rnd) + 1
   Next
   Call Creation_Usf("Desarmador", (NbColunas * LARG_BTN) + 5, (NbLinhas * LARG_BTN) + 22)  'criação UserFom
   Call Novo_Frame("Fram1", "", NbColunas * LARG_BTN, NbLinhas * LARG_BTN)             'criação Frame
   For Lign = 1 To NbLinhas                                                                'criação Botões
      For Col = 1 To NbColunas
         'os nomes dos botões : Col-Linhas
         Call Dictionnary("Fram1").Novo_Botão(Col & "-" & Lisnha, "", LARG_BTN * (Col - 1), LARG_BTN * (Linhas - 1), EstáNa(Col & "-" & Linhas, MineAdress), ModoFraude)
         Set Dictionnary ("Fram1"). Dictionnary (Col & "-" & Linhas).DictionnaryParente = Dictionnary ("Fram1"). Dictionnary
      Next Col
   Next Linha
   meuForm.Tag = Timer  'armazenamento da hora do início da partida na propriedade Tag do UserForm
   meuForm.Show         'exibição do desarmador 
   Exit Sub
ErroParâmetrosMacros:
   MsgBox "Favor verificar se você aprovou o acesso ao modelo objeto do projeto VBA."
End Sub

Private Sub Creation_Usf(Título As String, Largura As Double, Altura As Double)
'criação UserFom
   Set meuForm = ThisWorkbook.VBProject.VBComponents.Add(3)  'adicionamos ao projeto um módulo de UserFom
   Nome = meuForm.Name                                        'usamos o seu nome 
   VBA.UserForms.Add (Nome)                                  'adicionamos o UserFom ao projeto VBA
   Set meuForm = UserForms(UserForms.Count - 1)              'atribuímos este UserForm à nossa variável objeto 
   With euaForm                                              'atribuímos certas propriedades 
      .Caption = Título                                      'título
      .Width = Largura                                      'largura
      .Height = Altura                                     'altura
   End With
End Sub

Public Sub Novo_Frame(meuNome As String, Título As String, Largura As Double, Altura As Double)
'criação Frame
   If Dico.Exists(meuNome) = True Then Exit Sub              'se já existente abandonamos
   Dim minhaClass As New cDesarmador                             'criação de uma nova instância de nossa  classe
   Set minhaClass.Fram = maForm.Controls.Add("forms.frame.1")  'Criação de um  controle do tipo Botão
   Set minhaClass.meuForm = meuForm         'atribuímos o UserFom à propriedade "meuForm" de nossa instância de Classe
  minhaClass.Mine = boolMine             'definimos a propriedade  Mina do nosso botão  (True ou False)
   With minhaClass.Button                   'atribuímos certas propriedades do botão
      .Name = meuNome                   'seu nome
      .Caption = Título                 'título
      .Move Esquerda, Altura, LARG_BTN     ' sua localização
If ModoFraude Then                           'EM MODO FRAUDE, COLORE OS BOTÕES MINAS
         If boolMine Then .BackColor = COR_MINA Else .BackColor = COL_BTN
      Else
         .BackColor = COL_BTN
      End If
   End With
   Dictionnary.Add meuNome, minhaClass            'atribuímos  nossa instancia de classe ao Dictionnary
   Set minhaClass = Nothing
End Sub

Public Sub Novo_Botão(meuNome As String, Título As String, Esquerda As Double, Alto As Double, boolMine As Boolean, Opcional ModoFraude As Boolean)
'criação de Botões
   If Dictionnary.Exists(meuNome) = True Then Exit Sub                     'se já existe, fechamos
   Dim minhaClass As New cDesarmador                                      'criação de uma nova instância de nossa Classe
   Set minhaClass.Button = Fram.Controls.Add("forms.CommandButton.1")   'Criação de um controle do tipo Botão
   Set minhaClass.meuForm = meuForm         'atribuímos o UserForm à propriedade "meuForm" de nossa instância de Classe
   minhaClass.Mina = boolMine             'definimos a propriedade Mina do nosso botão (True ou False)
   With minhaClass.Bouton                 'definimos certas  propriedades do botão
      .Name = meuNome                            'seu nome
      .Caption = Título                          'seu título
      .Move Esquerda, Alt, LARG_BTN, LARG_BTN    'sua localização 
      If ModoFraude Then                           'EM MODO FRAUDE, COLORE OS BOTÕES DAS MINAS
         If boolMine Then .BackColor = COL_MINE Else .BackColor = COL_BOUTON
      Else
         .BackColor = COR_BOTÃO
      End If
   End With
   Dictionnary.Add meuNome, minhaClass            'atribuímos nossa instância de classe ao Dictionnary
   Set minhaClass = Nothing
End Sub

Private Function EstáNo(endereço As String, Tb) As Boolean
'função de pesquisa de um valor em uma tabela
   Dim i As Long
   For i = 0 To UBound(Tb) 'fecha sobre toda a variável da tabela passada em parâmetro 
      If Tb(i) = endereço Then EstáNo = True: Exit Function 'encontramos o elemento procurado > função verdadeiro, saimos 
   Next i
End Function

Private Sub Botão_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Procedimento de eventos quando apoiado, com a ajuda de um dos 2 botões do mouse, em um Botão do UserForm
   If Button = XlMouseButton.xlSecondaryButton Then    'clique direito 
      Select Case Bouton.Caption 'de acordo com o Título do botão 4 possibilidades
         Case "": Button.Caption = "!": Button.BackColor = COR_MINA_PROB        'se título  vazia: mostramos! (= atenção perigo)
         Case "!": Button.Caption = "?": Button.BackColor = COR_MINA_POSSÍVEL   'se tem título! : mostramos? (= dúvida)
         Case "?": Button.Caption = "": Button.BackColor = COR_BOTÃO           'se tem título? : não mostramos nada (= tirada a dúvida)
         Case Else:                                                              'senão (título = número (Número de minas vizinhas)) Não fazemos nada 
      End Select
   ElseIf Button = XlMouseButton.xlPrimaryButton Then  'clique esquerdo 
      If DicoParent.Item(Botão.Name).Mine Then                                  'se botão minado
         Call Exibe_Todas_Minas                                               'exibição de todas as minas
         MsgBox "Partida perdida"                                                  `mensagem perdida!
         meuForm.Hide                                                             'abandonamos 
      Else                                                                       'se botão não minado 
         Button.BackColor = COR_BOTÃO                                          'remete à cor padrão em caso de clique direito precedente  
         Dim minhaClass As cDesarmador                                            'chamamos o procedimento de desarmar 
         Set minhaClass = DictionnaryParent.Item(Button.Name)                              'procedimento recursivo de propagação 
         Call Desarme(minhaClass)                                                    'botões cujos Vizinhos não são minas
      End If
   End If
   If Partida_Ganha Then                                                         'lança a função  Partida_Ganha
      Call Exibe_Todas_Minas                                                  'se vitória: exibição das minas:
      MsgBox "Parabéns" & vbCrLf & "Partida ganha em: " & CInt(Timer - CDbl(meuForm.Tag)) & " segundos.", vbOKOnly + vbExclamation, "GANHO!"
      meuForm.Hide                   'abandonamos o UserForm. Isto aciona o destruidor da classe   End If
End Sub

Private Sub Exibe_Todas_Minas()
'Em caso de partida perdida, colore-se todos os botões minados
   Dim cle
   For Each cle In DictionnaryParent.keys 'fecha sobre todas as chaves de nosso DictionnaryParent
   'este contém todas as instâncias da classe contidas no Frame
      'se a instância da classe estiver minada > colorimos
      If DictionnaryParent.Item(cle).Mine Then DictionnaryParent.Item(cle).Button.BackColor = COR_MINA
   Next
End Sub

Private Sub Demine(Cl As cDesarmador)
'procedimento recursivo da descoberta dos botões não minados 
   Dim NbMinas As Integer
   NbMinas = ContaMinas(Cl.Button.Name)  'testamos o número de minas vizinhas
   If NbMinas > 0 Then                    'se o botão tem pelo menos uma mina entre seus vizinhos 
      Cl.Button.Caption = NbMinas         'exibimos este número de minas
      Cl.Decouverte = True                'descobrimos este  botão
   Else                                   'ao contrário
      If Cl.Decoberta = False Then       'Se o botão não for descoberto 
         Cl.Descoberto = True             'descobrimos 
         Cl.Botão.Visível = False        'tornamos a descoberta visível para o jogador ( > o botão desaparece)
         Que_Vizinhos Cl                 'procuramos quais são os botões Vizinhos deste botão
         Dim Tb() As cDesarmador, i As Integer
         Tb = Cl.Vizinhos
         For i = 0 To UBound(Tb)          'desarmamos todos os botões Vizinhos (RECURSIVIDADE)
            Desarme Tb(i)
         Next
      End If
   End If
End Sub

Private Function ContaMinas(Bout As String) As Integer
'função contando as minas contidas nos botões Vizinhos
   Dim i As Integer, j As Integer, Col As Integer, Lig As Integer
   Dim minhaClass As cDesarmador
   For i = -1 To 1               'incrementando a coluna e a linha de -1 à 1 "visamos" somente os 
      For j = -1 To 1            'botões Vizinhos daquele cujo nome passou para parâmetro
         Col = CInt(Split(Bout, "-")(0)) + i                   'incrementação  n° de coluna
         Lin = CInt(Split(Button, "-")(1)) + j                   'incrementação n° de linha
         If DictionnaryParent.Exists(Col & "-" & Lig) Then            'se o botão existe (evite o erro de "ultrapassar" o UserForm)
            Set minhaClass = DictionnaryParent.Item(Col & "-" & Lig)     `atribuímos à nossa variável o botão vizinho
            If minhaClass.Mine Then ContaMinas = ContaMinas + 1 'se ela estiver minada incrementamos nossa função com mais1  
         End If
      Next j
   Next i
End Function

Private Sub Que_Vizinhos(Cl As cDesarmador)
'procedimento afetando à propriedade Vizinhos() de um botão, a lista dos botões que o cercam 
   Dim i As Integer, j As Integer, Col As Integer, Lig As Integer
   Dim minhaClass As cDesarmador, ListaVizinhos() As cDesarmador, cpt As Byte
   For i = -1 To 1               'incrementando a coluna e a linha de -1 à 1 "visamos" somente os que      For j = -1 To 1            'botões Vizinhos daquele cujo o nome passou para parâmetro         
Col = CInt(Split(Cl.Button.Name, "-")(0)) + i      'incrementação n° de coluna
         Lin = CInt(Split(Cl.Button.Name, "-")(1)) + j      'incrementação  n° de linha
         'se o botão existir e que seu nome for diferente daquele passado para parâmetro (não somos nosso próprio vizinho;-)
         If DictionnaryParent.Exists(Col & "-" & Lin) And Cl.Button.Name <> Col & "-" & Lin Then
            Set minhaClass = DictionnaryParent.Item(Col & "-" & Lin)  'atribuímos à nossa variável o botão vizinho
            ReDim Preserve ListaVizinhos(cpt)                'redimensionamento da variável da tabela
            Set ListaVizinhos(cpt) = minhaClass                 'atribuímos nossa instância de classe (botão) à tabela
            cpt = cpt + 1
         End If
      Next j
   Next i
   Cl.Vizinhos = ListaVizinhos        'atribuímos à propriedade Vizinhos de nossa instância de classe (de nosso botão)
End Sub

Private Function Partida_Ganha() As Boolean
   Dim cle
   For Each cle In DictionnaryParent.keys 'fecha sobre todas as chaves de nosso DictionnaryParent
   '(ou seja, sobre todas as instâncias da Classe e sobre todos os botões)
      'Se o botão não for "descoberto" e não contiver nenhuma mina
      If DictionnaryParent.Item(chave).Descoberta = False And DictionnaryParent.Item(chave).Mina = False Then
         Partida_Ganha = False                                          'então, a partida não terminou
         Exit Function
      End If
   Next
   Partida_Ganha = True
End Function

Private Sub Class_Terminate()
'destruidor da classe cDesarmador
   Dim VBComp As VBComponente
   Set Dictionnary = Nothing            'suprime todas as instâncias de nossa Classe => todos os botões
   If Nome <> "" Then             'trata-se do UserForm (apenas as instâncias com a  propriedade  "Nome" preenchido)
      Set VBComp = ThisWorkbook.VBProject.VBComponents(Nome) 'nós o visamos
      ThisWorkbook.VBProject.VBComponents.Remove VBComp     nós 
   End If o excluímos
End Sub

Espero que tenham gostado!

Observação: o código do procedimento recursivo de propagação da descoberta de botões não minados foi muito simplificada através de nosso módulo de classe. Está faltando alguma propriedade? Crie-a em sua classe! Ex: a propriedades Vizinhos () ...
Jean-François Pillou

Nosso conteúdo é produzido em colaboração com especialistas em tecnologia da informação sob o comando de Jean-François Pillou, fundador do CCM.net e diretor digital do Grupo Figaro. CCM é um site sobre tecnologia líder em nível internacional e está disponível em 11 idiomas.

Mais informações sobre a equipe do CCM

Veja também