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.
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.
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.
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
É 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.
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.
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
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.
Foto: © Excel.