Creare uno UserForm in un modulo di classe su VBA

Ultimo aggiornamento 3 dicembre 2020 alle 12:33 da Claudia Scarciolla .

Come creare un UserForm con un numero dinamico di controlli in grado di reagire a certi eventi? Basta creare un UserForm e un modulo di classe. Infatti, assegnando alla classe i controlli creati dinamicamente nello UserForm, questi si posso fare reagire. Il fine sarà quello di ottenere un solo modulo in modo che la procedura venga semplificata e limitata a due, tre linee di codice. Si creerà, così, uno UserForm e il suo modulo, direttamente come oggetto, quindi grazie al proprio modulo di classe.

Requisiti necessari
I Codici VBA
- Il modulo di classe
- La procedura lato codice richiamante
Esempio più complesso, il gioco di Campo minato
- Il codice chiamante
- Il modulo di classe

Requisiti necessari

Nelle opzioni di Excel bisogna spuntare la casella Considera attendibile l'accesso al modello a oggetti dei progetti VBA. Per poterlo fare accedere a Opzioni di Excel > Centro protezione > Impostazioni Centro protezione > Impostazioni macro. Sarà necessario spuntare altri due riferimenti: Microsoft Forms 2.0 Object Library e Microsoft Visual Basic For Applications Extensibility 5.3, per fare questo nell'Editor VBA cliccare sul menu Strumenti > Riferimenti...

I Codici VBA

Nell'esempio seguente, creiamo uno UserForm contenente due bottoni che reagiscono al clic e rinviino, nel codice richiamante, la loro Caption.

Il modulo di classe

Creare un modulo di classe nel proprio progetto VBA e nominarlo PrimoEsempio (proprietà Name della classe) e inserirne il seguente codice:

Option Explicit
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Necessità di spuntare i due riferimenti seguenti (da menu Strumenti > Riferimenti)
    'Microsoft Forms 2.0 Object Library
    'Microsoft Visual Basic For Applications Extensibility 5.3
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Public myForm As Object                                        'UserForm
Public WithEvents Button As MSForms.CommandButton              'Bottone
Public Dict As Object                                          'Objet Dictionnary = la collezione di oggetti

Private Name As String         'Name => consente la costruzione e la distruzione dello UserForm

Private Sub Class_Initialize()
'costruttore della classe
   Set Dict = CreateObject("Scripting.dictionary")
End Sub

Public Function Value()
'il metodo Value della Classe consente la costruzione dello UserForm
'e restituire il valore
    NewUsf "Il mio primo UserForm" 'creazione dello UserForm
    NewButton "myButton1", "Primo Bottone, 120, 30, 5, 5 'creazione del primo bottone
    NewBouton "myButton2", "Secondo Bottone", 120, 30, 5, 35 'creazione del secondo bottone
    myForm.Show 'visualizzazione dello UserForm
    On Error GoTo fin
    Value = myForm.Tag 'diamo alla nostra funzione il valore contenuto nel tag dello UserForm
    Unload myForm
    Exit Function
fin:
End Function

Private Sub NewUsf(myCaption As String)
'procedura di creazione dello UserForm
    Set myForm = ThisWorkbook.VBProject.VBComponents.Add(3) 
    Name = myForm.Name
    VBA.UserForms.Add (Name)
    Set myForm = UserForms(UserForms.Count - 1)
    With myForm
      .Caption = myCaption
      .Width = 150
      .Height = 100
    End With
End Sub

Public Sub NewButton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double)
'procedura di creazione di un bottone di controllo
Dim Obj
    Set Obj = myForm.Controls.Add("forms.CommandButton.1")
    If Obj = True Then Exit Sub
    Dim cls As New PrimoEsempio
    Set cls.myForm = myForm
    Set cls.Button = Obj
    With cls.Button
        .Name = Name
        .Caption = Caption
        .Move Left, Top, Width, Height
    End With
    Dict.Add Name, cls
    Set cls = Nothing
End Sub

Private Sub Button_Click()
'procedura evento del clic su bottone
   myForm.Tag = Button.Caption
   myForm.Hide
End Sub

Private Sub Class_Terminate()
'distruttore classe
   Dim VBComp As VBComponent
   Set Dict = Nothing            'elimina tutte le istanze della nostra classe => tutti i bottoni
   If Name <> "" Then             'se si tratta dello UserForm (l'unica istanza ad avere una proprietà 'Name' riempito)
      Set VBComp = ThisWorkbook.VBProject.VBComponents(Name) 'selezionarlo
      ThisWorkbook.VBProject.VBComponents.Remove VBComp     'eliminarlo
   End If
End Sub

La procedura lato codice richiamante

Questo codice è semplificato. Si dispone, grazie al modulo di classe, di uno UserForm e di un metodo Value. Quest'ultimo sarà restituito nel punto desiderato utilizzando il seguente codice:

Sub test()
Dim MyForm As New PrimoEsempio
MsgBox MyForm.Value
Set MyForm = Nothing
End Sub

Colui che utilizza lo UserForm o la Classe sa cosa fare con un codice di tipo myForm.Value. Nulla di più facile: basterà inserire questo risultato in una cella, un textBox, o altro.

Esempio più complesso, il gioco di Campo minato

In questo esempio i tasti saranno creati casualmente, in un Frame che servirà da contenitore proprio dentro lo UserForm. Da notare, in questo esempio, che non verrà creato un metodo Value alla Classe, dato che non restituisce un valore.

Il codice chiamante

Da inserire in un modulo standard:

Sub Usf_Campominato()
  Dim MyForm As New cCampominato
  MyForm.Show 0 , False
End Sub

I parametri di questo UserForm sono: il primo (obbligatorio), 0.1 o 2, rappresenta la difficoltà (% numero di mine); il secondo parametro (facoltativo), vero o falso, rappresenta la Modalità Cheater attiva o meno.

Il modulo di classe

Creare un modello di classe del proprio progetto su VBA, nominarlo cCampominato (proprietà del Name della classe) e inserire il codice seguente:

Option Explicit
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Necessità di spuntare i due riferimenti seguenti (da menu Strumenti > Riferimenti)
    'Microsoft Forms 2.0 Object Library
    'Microsoft Visual Basic For Applications Extensibility 5.3
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

'Variabili pubbliche
Public myForm As Object                                         'UserForm
Public Fram As MSForms.Frame                                    'Frame = contenitore dei bottoni
Public Dict As Object                                           'Objet dictionary
Public DictParent As Object                                     'Objet dictionary
Public Mine As Boolean                                          'Proprietà Mine se True = bottone piegato
Public Decouverte As Boolean                                    'Proprietà scoperto se True = "terreno (bottone) sminato"
'variabili private
Private Name As String                                           'Name => permette la costruzione e la distruzione dello UserForm
Private cVicini() As cCampominato ' Proprietà sotto forma array (tabella) con lista dei bottoni vicini
'variabili pubbliche "eventi"
Public WithEvents Button As MSForms.CommandButton               'bottone 
'costanti
Private Const LARG_BTN As Byte = 18                             'dimensione dei bottoni
Private Const MIN_ROW As Byte = 7                              'minimo di linee
Private Const MAX_ROW As Byte = 30 - MIN_LIN                  'massimo di linee
Private Const MIN_COL As Byte = 7                               'minimo di colonne
Private Const MAX_COL As Byte = 40 - MIN_COL                    'massimo di colonne
Private Const PERCENT_SIMPLE As Byte = 10                      '% delle mine in modalità facile
Private Const PERCENT_MEDIUM As Byte = 2 * PERCENT_SIMPLE     '% delle mine in modalità media
Private Const PERCENT_HARD As Byte = 3 * PERCENT_SIMPLE       '% delle mine in modalità difficile
Private Const COL_MINE As Long = &H188B0                       'colore dei bottoni minati (per scoprirli)
Private Const COL_BOTTON As Long = &H8000000F                  'colore bottoni
Private Const COL_MINE_POSSIBLE As Long = &HFFFFFF             'colore se bottoni possibilmente minati (bottone visualizzato?) => dubbio
Private Const COL_MINE_PROB As Long = &H8080FF                 'colore se bottoni probabilmente minati (bottone visualizzato!) => attenzione pericolo

Property Get Vicini() As cCampominato()                           'proprietà di tipo tabella
'proprietà Vicini in lettura
   Vicini = cVicini 
End Property

Property Let Vicini(ByRef newVicini () As cCampominato)
'proprietà Vicini in Scrittura
   cVicini = newVicini
End Property

Private Sub Class_Initialize()
'cosntruttore della classe cCampominato
   Set Dict = CreateObject("Scripting.dictionary")
End Sub

Public Sub Show(ByRef Difficult As Long, Optional CheatMode As Boolean = False)
'Metodo Show : permette la visualizzazione dello UserForm
   On Error GoTo ErroreParametriMacro        ' Verifica se 'Considera attendibile l'accesso al modello a oggetti dei progetti VBA' è stato spuntato nelle opzioni di Excel
   With ThisWorkbook.VBProject: End With
   Dim Row As Long, Col As Long, NbRows As Long, NbColumns As Long
   Dim NbMines As Long, MineAdress() As String, CptMine As Long
   Randomize Timer                             'inizio generatore numeri aleatori
   NbLines = Int(MAX_ROW * Rnd) + MIN_ROW 'Numeri di linee di bottoni
   NbColonnes = Int(MAX_COL * Rnd) + MIN_COL  'Numeri di colonne di bottoni
   Select Case Difficult                       'Numero di mine a seconda la difficoltà scelta
      Case 0: Difficult = PERCENT_SIMPLE
      Case 1: Difficult = PERCENT_MEDIUM
      Case 2: Difficult = PERCENT_HARD
      Case Else: Exit Sub
   End Select
   NbMines = (NbRows * NbColumns) * Difficult \ 100
   ReDim MineAdress(NbMines)
   For CptMine = 1 To NbMines                 'coordinate delle Mine: Col-Row
      MineAdress(CptMine) = Int(NbColonnes * Rnd) + 1 & "-" & Int(NbRows * Rnd) + 1
   Next
   Call Creation_Usf("Campominato", (NbColumns * LARG_BTN) + 5, (NbRows * LARG_BTN) + 22) 'creazione UserFom
   Call New_Frame("Fram1", "", NbColumns * LARG_BTN, NbRows * LARG_BTN)             'creazione Frame
   For Row = 1 To NbRows                                                                'creazione bottoni
      For Col = 1 To NbColumns
         'I nomi dei bottoni: Col-Lin
         Call Dico("Fram1").New_Button(Col & "-" & Row, "", LARG_BTN * (Col - 1), LARG_BTN * (Row - 1), Dentro(Col & "-" & Row, MineAdress), CheatMode)
         Set Dict("Fram1").Dict(Col & "-" & Row).DictParent = Dict("Fram1").Dict
      Next Col
   Next Row
   myForm.Tag = Timer 'memorizza ora inzio partita nella proprietà Tag dello UserForm
   myForm.Show         'visualizzazione del campo minato
   Exit Sub
ErroreParametriMacro:
   MsgBox "Si prega di attivare l'opzione: Considera attendibile l'accesso al modello a oggetti dei progetti VBA"
End Sub

Private Sub Creazione_Usf(Titolo As String, Larghezza As Double, Altezza As Double)
'creazione Userfom
   Set myForm = ThisWorkbook.VBProject.VBComponents.Add(3 'aggiunta al progetto di un modello di UserForm
   Name = myForm.Name                                        'selezionare il nome
   VBA.UserForms.Add (Name)                                  'aggiunta dello UserForm al progetto VBA
   Set myForm = UserForms(UserForms.Count - 1)              'assegnare questo UserForm alla varibile oggetto
   With myForm                                              'assegnare alcune proprietà
      .Caption = Titolo                                      'titolo
      .Width = Larghezza                                      'larghezza
      .Height = Altezza                                     'altezza
   End With
End Sub

Public Sub New_Frame(myName As String, Titolo As String, Larghezza As Double, Altezza As Double)
'creazione Frame
   If Dict.Exists(myName) = True Then Exit Sub              'uscire se già esistente
   Dim myClass As New cCampominato                             'creazione di una nuova istanza della nostra classe
  Set myClass.Fram = myForm.Controls.Add("forms.frame.1") 'Creazione di un controllo di tipo Frame
   Set myClass.myForm = myForm         'assegnare lo UserForm alla proprietà "myForm" della istanza di classe
   With myClass.Fram                   'assegnargli alcune proprietà
      .Name = myName                   'nome
      .Caption = Titolo                 'titolo
      .Move 0, 0, Larghezza, Altezza     'posizione
   End With
   Dict.Add myName, myClass            'aggiungere la nostra istanza al Dizionario
   Set myClass = Nothing
End Sub

Public Sub New_Button(myName As String, Titre As String, Sinistra As Double, Alto As Double, boolMine As Boolean, Optional CheatMode As Boolean)
'creare i Bottoni
   If Dico.Exists(myName) = True Then Exit Sub                       'uscire se esiste
   Dim myClass As New cCampominato                                      'creare una nuova istanza della classe
   Set myClass.Button = Fram.Controls.Add("forms.CommandButton.1") 'Creare un control di tipo Bottone
   Set myClass.myForm = myForm         'assegnare lo UserForm alla proprietà "myForm" della istanza della classe
   myClass.Mine = boolMine             'definire la proprietà Mine del bottone (True o False)
   With myClass.Button                 'definire alcune proprietà del bottone
      .Name = myName                            'nome
      .Caption = Titolo                          'Caption
      .Move Sinistra, Alto, LARG_BTN, LARG_BTN    'posizione
      If CheatMode Then                           'In cheat mode, DARE COLORE AI BUTTONI MINE
         If boolMine Then .BackColor = COL_MINE Else .BackColor = COL_BUTTON
      Else
         .BackColor = COL_BUTTON
      End If
   End With
   Dict.Add myName, myClass            'aggiungere l'istanza della classe al Dizionario
   Set myClass = Nothing
End Sub
Private Function Dentro(adresse As String, Tb) As Boolean
'funzione per cercare un valore in una variabile tabella
   Dim i As Long
   For i = 0 To UBound(Tb) 'loop su tutta la var tabella
      If Tb(i) = adress Then Dentro = True: Exit Function 'se trovato l'elemento cercato => funzione true, uscire
   Next i
End Function

Private Sub Button_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Procedura evento quando si schiaccia, tasto destro o sinistro del mouse, su un Buttone dello UserForm
   If Button = XlMouseButton.xlSecondaryButton Then    'clic destro
      Select Case Button.Caption 'a seconda del Caption del buttone 4 possibilità
         Case "": Button.Caption = "!": Button.BackColor = COL_MINE_PROB        'se caption è vuoto: visualizzare ! (= attenzione pericolo)
         Case "!": Button.Caption = "?": Button.BackColor = COL_MINE_POSSIBLE   'se caption è !: visualizzare? (= dubbio)
         Case "?": Button.Caption = "": Button.BackColor = COL_BUTTON           'se caption è ?: visualizzare niente (= levare il dubbio)
         Case Else:                                                              'altrimenti (caption = chiffra (Numero di mine vicine)) non fare niente
      End Select
   ElseIf Button = XlMouseButton.xlPrimaryButton Then 'clic sinistro
      If DictParent.Item(Button.Name).Mine Then                                  'se bottone minato
         Call Visualizza_Tutte_Mine                                               'visualizzare tutte le mine
         MsgBox "Hai perso!"                                                  'partita persa
         myForm.Hide                                                             'uscire
      Else                                                                       'se bottone non minato
         Button.BackColor = COL_BUTTON                                          'ripristinare il colore predefinito in caso di clic destro predente
         Dim myClass As cCampominato                                                'Richiamare la procedura di sminamento
         Set myClass = DictParent.Item(Button.Name)                              'procedura ricursiva di propagazione
         Call smina(myClass)                                                    'bottoni i quali vicini non sono minati
      End If
   End If
   If Partita_Vince Then                                                         'avviare la funzione Partita_Vince
      Call Visualizza_Tutte_Mine                                                  'se vince : visualizza mine e messaggio:
      MsgBox "Bravo!" & vbCrLf & "Hai vinto! Tempo scaduto : " & CInt(Timer - CDbl(myForm.Tag)) & " secondi.", vbOKOnly + vbExclamation, "VINCE!"
      myForm.Hide                   'uscire dallo UserForm. Ciò che avvia il distruttore della classe
   End If
End Sub

Private Sub Visualizza_Tutte_Mine()
'Se partita persa, colore tutti bottoni minati
   Dim chiave
   For Each chiave In DictParent.keys 'loop su tutte le chiave del DictParent
   'quest'ultimo contiene tutte le istanze della classe contenute nel Frame
      'se l'istanza di classe è minata => colore
      If DictParent.Item(chiave).Mine Then DictParent.Item(chiave).Button.BackColor = COL_MINE
   Next
End Sub

Private Sub Smina (Cl As cCampominato)
'procedura ricursiva di propagazione della scoperta dei bottoni non minati
   Dim NbMine As Integer
   NbMine = CountMine(Cl.Button.Name) 'fare il test del numero delle mine vicine
   If NbMines > 0 Then                    'se il bottone a al meno una mina tra i vicini
      Cl.Bouton.Caption = NbMines         'visualizzare il numero delle mine
      Cl.Scoperta= True                'visualizzare il bottone
   Else                                   'altrimenti
      If Cl.Scoperta = False Then       'se il bottone non è ancora scoperto
         Cl.Scoperta = True             'scoprirlo
         Cl.Bouton.Visible = False        'rendere la scoperta visibile dal giocatore (=> il bottone sparisce)
         Quale_vicino Cl                 'cercare quali bottoni sono i vicini di questo bottone
         Dim Tb() As cMine, i As Integer
         Tb = Cl.Vicini
         For i = 0 To UBound(Tb)          'scoprire tutti i bottoni vicini (RICORSIVITÀ)
            Scopri_Mina Tb(i)
         Next
      End If
   End If
End Sub

Private Function ContareMine(Bott As String) As Integer
'funzione per contare le mine contenute nei bottoni vicini
   Dim i As Integer, j As Integer, Col As Integer, Lin As Integer
   Dim myClass As cMine
   For i = -1 To 1               'incrementare la colonna e la linea da -1 a 1 solo per i bottoni vicini a
   For j = -1 To 1              'a quello il cui nome è passato in parametro
         Col = CInt(Split(Bott, "-")(0)) + i                   'incrementare n° di colonna
         Lin = CInt(Split(Bout, "-")(1)) + j                   'incrementare n° di linea
         If DictParent.Exists(Col & "-" & Lin) Then            'se il bottone esiste (non andare fuori lo UserForm)
            Set myClass = DictParent.Item(Col & "-" & Lin) 'assegnare alla variabile il bottone vicino
            If myClass.Mine Then ContareMine = ContareMine + 1 'se est minato, incrementare la funzioni di 1
         End If
      Next j
   Next i
End Function

Private Sub Quale_vicino(Cl As cMine)
'procedura per assegnare, alla proprietà Vicini() di un bottone, la lista dei bottoni che lo circondano
   Dim i As Integer, j As Integer, Col As Integer, Lin As Integer
   Dim myClass As cMine, ListaVicini() As cMine, cpt As Byte
   For i = -1 To 1               'incrementare la colonna et la linea da -1 a 1 solo per i bottoni vicini a
      For j = -1 To 1            'a quello il cui nome è passato in parametro
         Col = CInt(Split(Cl.Bottone.Name, "-")(0)) + i     'incrementare n° di colonna
         Lin = CInt(Split(Cl.Bouton.Name, "-")(1)) + j      'incrementare n° di linea
         'se il bottone esiste e il suo nome è diverso di quello passato in parametro
         If DictParent.Exists(Col & "-" & Lin) And Cl.Bouton.Name <> Col & "-" & Lin Then
            Set maClass = DicoParent.Item(Col & "-" & Lin) 'assegnare alla variabile il bottone vicino
            ReDim Preserve ListaVicini(cpt)                'ridimensionare variabile tabella
            Set ListaVicini(cpt) = myClass                 'assegnare l'istanza di classe (bottone) alla tabella
            cpt = cpt + 1
         End If
      Next j
   Next i
   Cl.Vicini = ListaVicini        'assegnare la proprietà Vicini dell'istanza di classe (del bottone)
End Sub

Private Function Partita_Vinta() As Boolean
   Dim chiave
   For Each chiave In DictParent.keys 'loop su tutte le chiavi del DictParent
   '(quindi tutte le istanze della classe, quindi su tutti i bottoni)
      'Se il bottone non è "scoperto" e non contiene una mina
      If DictParent.Item(chiave).Scoperta = False And DictParent.Item(chiave).Mine = False Then
         Partita_Vinta = False                                          'allora la partita non est finita
         Exit Function
      End If
   Next
   Partita_Vinta = True
End Function

Private Sub Class_Terminate()
'distruttore della della classe cMine
   Dim VBComp As VBComponent
   Set Dico = Nothing            'cancellare tutte le istanze della classe => tutti i bottoni
   If Name <> "" Then             'si tratta dello UserForm (unica istanza avendo una proprietà "Name" assegnata)
      Set VBComp = ThisWorkbook.VBProject.VBComponents(Name) 'indicarlo
      ThisWorkbook.VBProject.VBComponents.Remove VBComp     'cancellarlo
   End If
End Sub

Nota Bene: il codice della procedura ricorsiva di propagazione della scoperta dei bottoni non minati è stata semplificata grazie al nostro modulo di classe.