Como criar um formulário com um certo número de testes dinâmicos e poder verificar se eles reagem a certos eventos? Para conseguir isso, poderíamos criar um Userform e um módulo de classe. Ao atribuir à classe os controles criados dinamicamente no UserForm, 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.
Vamos criar o UserForm e seu módulo diretamente como um objeto, e isso graças ao nosso módulo de classe.
Pré-requisitos
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, é 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.
Códigos
Vamos criar um UserForm com dois botões. Esses dois botões deverão reagir ao clique e retornar, no código de chamada, a sua legenda.
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 esse 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
Procedimento do código de chamada
É bem simples. 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.
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
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 públicas
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
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.
Este documento, intitulado 'VBA - Criação de um UserForm em um módulo de Classe', está disponível sob a licença Creative Commons. Você pode copiar e/ou modificar o conteúdo desta página com base nas condições estipuladas pela licença. Não se esqueça de creditar o CCM (br.ccm.net) ao utilizar este artigo.
