Forum du club des d�veloppeurs et IT Pro - Blogs - pijaku

L'Objet DialogSheet, une alternative aux Userforms - Partie 2

pijaku — Tue, 02 Oct 2018 07:45:08 GMT

________________________________________________________

Ce billet est la suite de cette premi�re partie.

Nous avions, dans cette premi�re partie, fini de remplir notre liste de liste modifiable fixe.
R�glons notre zone d'�dition :

Clic droit / format de contr�le s�lectionner Entier :
Ceci, juste afin de tester l'une des possibilit�s (nombreuses) offertes par l'Objet DialogSheet et les contr�les de formulaire (cf ci-dessous).

Voil�, nous en avons termin� avec la pr�paration.
Ne reste que la partie VBA et code de cette boite de dialogue.
Faisons donc r�agir nos boutons...
Clic droit sur le bouton OK/Affecter une macro :

Changer (ou pas) le nom de la macro :

Dans l'�diteur VBA :
Placez ce code :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Bouton_Ok_Click()
 Dim Fruit As String
 
   With Sheets("Dialogue1")
      With .Shapes("Zone combinée 4").ControlFormat
         If .ListIndex > 0 Then
            Fruit = .List(.ListIndex)
         End If
      End With
      With .Shapes("Zone d'édition 5")
         If .TextFrame.Characters.Count > 0 Then
            MsgBox "Commander d'urgence : " & .TextFrame.Characters.Text & " " & Fruit
         End If
      End With
   End With
End Sub
Vous disposez maintenant d'une bo�te de dialogue fonctionnelle.

Pour terminer, nous allons masquer un peu tout cela, juste pour l'esth�tique de votre classeur.
Masquer la feuille : clic droit/Masquer :

Ins�rer un bouton dans la Feuil1 (par exemple)
Affecter une macro � ce bouton :
Dans l'�diteur VBA placer ce code :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
3
4
5
6
7
Sub Bouton_Commande_Click()
   With DialogSheets("Dialogue1")
      .Shapes("Zone combinée 4").ControlFormat.ListIndex = 0
      .Shapes("Zone d'édition 5").TextFrame.Characters.Text = ""
      .Show
   End With
End Sub
Ne nous reste plus qu'� tester.

Clic sur le bouton :

Choisir une valeur dans la zone de liste et saisir n'importe quoi (sauf un entier) dans la zone d'�dition :

Notre MsgBox s'affiche bien.
Mais un message d'Excel appara�t :

Et nous emp�che de quitter :

Cette alternative aux Userforms n'est pas �vidente � coder. Nous avons, en effet, davantage l'habitude des contr�les ActiveX.
Mais, une fois ma�tris�e, cela permet de se passer de moultes lignes de code rendues inutiles...

A lire ...
A lire �galement.

La cr�ation de telles bo�tes peut-�tre enti�rement r�alis�e en VBA : exemple

A++

L'Objet DialogSheet, une alternative aux Userforms - Partie 1

pijaku — Tue, 02 Oct 2018 07:19:22 GMT

_________________________________________________

Bonjour,

Ce billet sera en deux parties en raison du nombre limit� d'images par message.

Ayant d�couvert cet objet r�cemment, je me permet de venir vous d�crire comment s'en servir.

Il s'agit donc d'un type de feuille particulier vous permettant de cr�er un formulaire de saisie type bo�te de dialogue.

Voici, tout en images, un exemple de cr�ation.

Ins�rer la feuille de Dialogue :
Pour cela, clic droit sur un des onglets de feuille existante et choisissez : Ins�rer

Choisir : Boite de dialogue Microsoft Excel 5.0 :
puis cliquer sur OK

Voici votre feuille de dialogue cr��e :

Ex�cutons l�, pour voir :
Pour se faire, clic droit dans le fond de la bo�te et cliquer sur Ex�cuter la bo�te de dialogue.

Votre boite s'affiche comme ceci :

Bon.
C'est bien joli, mais, comme �a, on ne peut pas en faire grand chose...
Ajoutons donc des contr�les!

Onglet d�veloppeur, menu Ins�rer :

Note : nous n'avons acc�s qu'aux contr�les de formulaire, pas aux ActiveX.

Ins�rons donc :

2 Etiquettes :

1 zone d'�dition :

1 zone de liste d�roulante fixe modifiable :

Apr�s quelques modifications...

C'est mieux, mais... Notre liste est toujours vide.
Placez, dans une autre feuille de votre classeur (Feuil1 pour l'exemple), des valeurs en A1:A10, puis :

Clic droit sur la zone de liste :

Format de contr�le : remplir la Plage d'entr�e :

La suite : partie 2.

3 petits jeux : Tic-Tac-Toe (morpion) - Pig The Dice (jeu du cochon) - Bulls And Cows (MasterMind)

pijaku — Fri, 28 Sep 2018 09:31:09 GMT

____________________________________________________________________

Bonjour,

D�tournons un peu (beaucoup) Excel pour s'amuser avec trois petits jeux.

Le jeu du morpion (Tic-Tac-Toe) :
Une variante du grand classique. Ce jeu se joue seul contre l'ordinateur.
Vous avez la possibilit� de tricher et donc de r�duire les chances de l'ordi...

Mise en garde : se joue sur la feuille active. Veillez � ne pas y avoir de donn�es !

Pour y jouer, copier-coller le code ci-dessous dans un Module standard et ex�cuter la Sub Morpion...

Le code :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
Option Explicit
 
Private Lines(1 To 3, 1 To 3) As String
Private Nb As Byte, Joueur As Byte
Private Gagne As Boolean, Fin As Boolean, Annule As Boolean
 
Sub Morpion()
Dim P As String, CheatMode As Boolean, i&
    columns("C:E").ColumnWidth = 2.43
    columns("C:E").Cells.Clear
    rows("1:200").RowHeight = 16.5
    MsgBox "Vous-avez les X, le pc les O..." & vbCrLf & "Bonne partie"
    InitLines
    printLines Nb
    i = MsgBox("Voulez-vous tricher?", vbYesNo)
    CheatMode = (i <> vbYes)
    Do
        P = QuiJoue
        If P = "Humain" Then
            Call HumainJoue
            Gagne = IsWinner("X")
        Else
            Call OrdiJoue(CheatMode)
            Gagne = IsWinner("O")
            printLines Nb
        End If
        If Not Gagne Then Fin = IsEnd
    Loop Until Gagne Or Fin Or Annule
    If Not Fin And Not Annule Then
        Nb = Nb + 1
        printLines Nb
        MsgBox P & " Gagne !"
    ElseIf Annule Then
        MsgBox "Annulation par l'utilisateur"
    Else
        Nb = Nb + 1
        printLines Nb
        MsgBox "Game Over!"
    End If
End Sub
Sub InitLines(Optional s As String)
Dim i As Byte, j As Byte
    If s = vbNullString Then s = "#"
    Annule = False
    Nb = 0: Joueur = 0
    For i = LBound(Lines, 1) To UBound(Lines, 1)
        For j = LBound(Lines, 2) To UBound(Lines, 2)
            Lines(i, j) = s
        Next j
    Next i
End Sub
Sub printLines(Nb As Byte)
Dim i As Byte, j As Byte, strT As String
   Range("C" & rows.Count).End(xlUp).Offset(1, 0).Value = "Tour n° " & Nb
   Range("C" & rows.Count).End(xlUp).Offset(1, 0).Resize(3, 3).Value = Lines
End Sub
Function QuiJoue(Optional s As String) As String
    If Joueur = 0 Then
        Joueur = 1
        QuiJoue = "Humain"
    Else
        Joueur = 0
        QuiJoue = "Ordi"
    End If
End Function
Sub HumainJoue(Optional s As String)
Dim L As Byte, C As Byte, BienJoue As Boolean
    Do
        L = Application.InputBox("Choix de la ligne", "Numérique uniquement", Type:=1)
        If L = 0 Then
            Annule = True
        Else
            If L > 0 And L < 4 Then
                C = Application.InputBox("Choix de la colonne", "Numérique uniquement", Type:=1)
                If C > 0 And C < 4 Then
                    If Lines(L, C) = "#" And Not Lines(L, C) = "X" And Not Lines(L, C) = "O" Then
                        Lines(L, C) = "X"
                        BienJoue = True
                    End If
                ElseIf C = 0 Then
                    Annule = True
                End If
            End If
         End If
    Loop Until BienJoue Or Annule
End Sub
Sub OrdiJoue(booB As Boolean)
Dim L As Byte, C As Byte, BienJoue As Boolean
    If booB Then
        For L = LBound(Lines, 1) To UBound(Lines, 1)
            For C = LBound(Lines, 2) To UBound(Lines, 2)
                If Lines(L, C) = "#" Then
                    Lines(L, C) = "O"
                    If IsWinner("O") Then
                        Lines(L, C) = "O"
                        Nb = Nb + 1
                        Exit Sub
                    Else
                        Lines(L, C) = "#"
                    End If
                End If
            Next C
        Next L
        For L = LBound(Lines, 1) To UBound(Lines, 1)
            For C = LBound(Lines, 2) To UBound(Lines, 2)
                If Lines(L, C) = "#" Then
                    Lines(L, C) = "X"
                    If IsWinner("X") Then
                        Lines(L, C) = "O"
                        Nb = Nb + 1
                        Exit Sub
                    Else
                        Lines(L, C) = "#"
                    End If
                End If
            Next C
        Next L
    End If
    Randomize Timer
    Do
        L = Int((Rnd * 3) + 1)
        C = Int((Rnd * 3) + 1)
        If Lines(L, C) = "#" And Not Lines(L, C) = "X" And Not Lines(L, C) = "O" Then
            Lines(L, C) = "O"
            BienJoue = True
        End If
    Loop Until BienJoue
End Sub
Function IsWinner(s As String) As Boolean
Dim i As Byte, j As Byte, Ch As String, strTL As String, strTC As String
    Ch = String$(UBound(Lines, 1), s)
    For i = LBound(Lines, 1) To UBound(Lines, 1)
        For j = LBound(Lines, 2) To UBound(Lines, 2)
            strTL = strTL & Lines(i, j)
            strTC = strTC & Lines(j, i)
        Next j
        If strTL = Ch Or strTC = Ch Then IsWinner = True: Exit For
        strTL = vbNullString: strTC = vbNullString
    Next i
    If Not IsWinner Then
        strTL = Lines(1, 1) & Lines(2, 2) & Lines(3, 3)
        strTC = Lines(1, 3) & Lines(2, 2) & Lines(3, 1)
        If strTL = Ch Or strTC = Ch Then IsWinner = True
    End If
End Function
Function IsEnd() As Boolean
Dim i As Byte, j As Byte
    For i = LBound(Lines, 1) To UBound(Lines, 1)
        For j = LBound(Lines, 2) To UBound(Lines, 2)
            If Lines(i, j) = "#" Then Exit Function
        Next j
    Next i
    IsEnd = True
End Function

Le jeu du cochon (jeu de d� : Pig the dice) :
R�gles :
� chaque tour, un joueur jette un d� � plusieurs reprises jusqu'� ce que :

soit 1 soit tir�,
ou que le joueur d�cide de "garder":
- Si le joueur obtient un 1, il ne marque rien et c'est au joueur suivant de jeter le d�,
- Si le joueur obtient un autre nombre, il est ajout� au total de ce tour et le tour du joueur continue.
- Si le joueur choisit de "garder", le total des points du tour est ajout� � son score global, et c'est au joueur suivant de jeter le d�.

Le premier joueur � marquer 100 points ou plus gagne.

Pour y jouer, copier-coller le code ci-dessous dans un Module standard et ex�cuter la Sub Cochon.

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Sub Cochon()
Dim Scs() As Byte, Ask As Integer, Np As Boolean, Go As Boolean
Dim cp As Byte, Rd As Byte, NbP As Byte, ScBT As Byte
 
    Const INPTXT As String = "Nombre de joueurs : "
    Const INPTITL As String = "Numérique uniquement"
    Const ROL As String = "Joueur ¤¤¤¤ lance le dé."
    Const MSG As String = "Voulez-vous garder votre score : "
    Const TITL As String = "Total si vous gardez : "
    Const Res As String = "Le dé donne : ¤¤¤¤ points."
    Const ONE As String = "Le dé donne : 1 point. Désolé!" & vbCrLf & "Joueur suivant."
    Const WIN As String = "Le joueur ¤¤¤¤ a gagné le jeu du cochon!"
    Const STW As Byte = 100
 
    Randomize Timer
    NbP = Application.InputBox(INPTXT, INPTITL, 2, Type:=1)
    ReDim Scs(1 To NbP)
    cp = 1
    Do
        ScBT = 0
        Do
            MsgBox Replace(ROL, "¤¤¤¤", cp)
            Rd = Int((Rnd * 6) + 1)
            If Rd > 1 Then
                MsgBox Replace(Res, "¤¤¤¤", Rd)
                ScBT = ScBT + Rd
                If Scs(cp) + ScBT >= STW Then
                    Go = True
                    Exit Do
                End If
                Ask = MsgBox(MSG & ScBT, vbYesNo, TITL & Scs(cp) + ScBT)
                If Ask = vbYes Then
                    Scs(cp) = Scs(cp) + ScBT
                    Np = True
                End If
            Else
                MsgBox ONE
                Np = True
            End If
        Loop Until Np
        If Not Go Then
            Np = False
            cp = cp + 1
            If cp > NbP Then cp = 1
        End If
    Loop Until Go
    MsgBox Replace(WIN, "¤¤¤¤", cp)
End Sub

Version populaire du Mastermind (Bulls and Cows) :
R�gles

Tous les chiffres dans le nombre secret sont diff�rents.
Si dans votre proposition il y a des chiffres du nombre secret, aux bons endroits, ce sont des Taureaux.
Si dans votre proposition il y a des chiffres du nombre secret, mais pas aux bons endroits, ce sont des Vaches.

Pour y jouer, copier-coller le code ci-dessous dans un Module standard et ex�cuter la Sub Bulls_And_Cows.

Le code :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Sub Bulls_and_cows()
Dim strNb As String, strIn As String, strMsg As String, strTemp As String
Dim boolEnd As Boolean, CheatMode As Boolean
Dim lngCpt As Long
Dim i As Byte, bytCow As Byte, bytBull As Byte
Const NB_CHIFFRES As Byte = 4
Const MAX_ESSAIS As Byte = 25
    strNb = Nombre_Secret(NB_CHIFFRES)
    If MsgBox("Voulez-vous tricher?", vbYesNo) = vbYes Then MsgBox strNb
    Do
        bytBull = 0: bytCow = 0: lngCpt = lngCpt + 1
        If lngCpt > MAX_ESSAIS Then strMsg = "Maximum d'essais atteind. Désolé partie perdue!": Exit Do
        strIn = Question(NB_CHIFFRES)
        If strIn = "Exit Game" Then strMsg = "Abandon utilisateur": Exit Do
        For i = 1 To Len(strNb)
            If Mid$(strNb, i, 1) = Mid$(strIn, i, 1) Then
                bytBull = bytBull + 1
            ElseIf InStr(strNb, Mid$(strIn, i, 1)) > 0 Then
                bytCow = bytCow + 1
            End If
        Next i
        If bytBull = NB_CHIFFRES Then
            boolEnd = True: strMsg = "Vous gagnez en " & lngCpt & " essai" & IIf(lngCpt = 1, "", "s") & " !"
        Else
            strTemp = strTemp & vbCrLf & "Avec : " & strIn & " ,vous avez : " & bytBull & " taureaux, " & bytCow & " vaches."
            MsgBox strTemp
        End If
    Loop While Not boolEnd
    MsgBox strMsg
End Sub
Function Nombre_Secret(NbDigits As Byte) As String
Dim myColl As New Collection
Dim strTemp As String
Dim bytAlea As Byte
    Randomize
    Do
        bytAlea = Int((Rnd * 9) + 1)
        On Error Resume Next
        myColl.Add CStr(bytAlea), CStr(bytAlea)
        If Err <> 0 Then
            On Error GoTo 0
        Else
            strTemp = strTemp & CStr(bytAlea)
        End If
    Loop While Len(strTemp) < NbDigits
    Nombre_Secret = strTemp
End Function
Function Question(NbDigits As Byte) As String
Dim boolGood As Boolean, strIn As String, i As Byte, NbDiff As Byte
    Do While Not boolGood
        strIn = InputBox("Entrez un nombre (à " & NbDigits & " chiffres)", "Nombre")
        If StrPtr(strIn) = 0 Then strIn = "Exit Game": Exit Do
        If strIn <> "" Then
            If Len(strIn) = NbDigits Then
                NbDiff = 0
                For i = 1 To Len(strIn)
                    If Len(Replace(strIn, Mid$(strIn, i, 1), "")) < NbDigits - 1 Then
                        NbDiff = 1
                        Exit For
                    End If
                Next i
                If NbDiff = 0 Then boolGood = True
            End If
        End If
    Loop
    Question = strIn
End Function

Enjoy !
;)

A++

G�n�ration de cha�ne de caract�res al�atoires

pijaku — Thu, 27 Sep 2018 10:15:28 GMT

___________________________________________________________________________________

Bonjour,

On peut, pour x raisons (obfuscation de code, g�n�ration de mots de passe, etc...), avoir besoin de g�n�rer des chaines de caract�res complexes ET al�atoires.

Je vous donne deux fonctions qui le font, pour vous...

La premi�re : GenerateStringAlea comporte deux arguments :

n As Long : la longueur de la cha�ne voulue (minimum 4 caract�res),
e As Boolean : si True, �vite la suite de 2 caract�res similaires visuellement (exemple O0)

Dans cette fonction vous ne pouvez pas choisir le nombre de lettres Majuscules, minuscules, le nombre de chiffres ni de caract�res sp�ciaux.

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Public Function GenerateStringAlea(n As Long, e As Boolean) As String
'create 1 String without pattern (just with the String's lenght and similar visually)
Dim t As String, i As Long, j As Long, A As Boolean, b As Boolean, C As Boolean, d As Boolean
    Randomize Timer
    If n < 4 Then
        GenerateStringAlea = "Error. Numbers of characters is too small. Min : 4"
    ElseIf n >= 4 And n < 7 Then
        t = Alea_Caract$(122, 97) & Alea_Caract$(90, 65) & Alea_Caract$(57, 48) & Alea_Car_Spec$
        For j = 5 To n
            i = Int((4 * Rnd) + 1)
            Select Case i
                Case 1: t = t & Alea_Caract$(122, 97)
                Case 2: t = t & Alea_Caract$(90, 65)
                Case 3: t = t & Alea_Caract$(57, 48)
                Case 4: t = t & Alea_Car_Spec$
            End Select
        Next j
        GenerateStringAlea = Shuffle_Letters(t)
    Else
        Do
            i = Int((4 * Rnd) + 1)
            Select Case i
                Case 1: t = t & Alea_Caract$(122, 97): A = True
                Case 2: t = t & Alea_Caract$(90, 65): b = True
                Case 3: t = t & Alea_Caract$(57, 48): C = True
                Case 4: t = t & Alea_Car_Spec$: d = True
            End Select
            If Len(t) >= 2 And e Then
                If Similar_Characters(t) Then t = Left$(t, Len(t) - 1)
            End If
            If Len(t) = n Then
                If A And b And C And d Then
                    Exit Do
                Else
                    Efface t, A, b, C, d
                    GenerateStringAlea = GenerateStringAlea(n, e)
                End If
            ElseIf Len(t) > n Then
                Efface t, A, b, C, d
                GenerateStringAlea = GenerateStringAlea(n, e)
            End If
        Loop
        GenerateStringAlea = Shuffle_Letters(t)
    End If
End Function

La seconde : GenerateStringAleaPattern comporte �galement deux arguments :

s As String : le "pattern" souhait� (cf exemple ci-dessous),
e As Boolean : si True, �vite la suite de 2 caract�res similaires visuellement (exemple O0)

Exemple de Pattern : "A/9-a/1-9/4-!/5"
Les caract�res rouge et gras ci-dessus ne sont pas obligatoires, mais il faut conserver les m�mes s�parateurs : / et - ET ne pas remplacer A, a, 9 ou ! par d'autres caract�res.
La signification :

A/9 := 9 majuscules
a/1 := 1 minuscule
9/4 := 4 chiffres
!/5 := 5 caract�res sp�ciaux

Autres patterns possibles, sans chiffres : "A/5-a/2-!/3" ou encore sans caract�res minuscules : "A/8-9/5-!/3", etc. tout est envisageable... ("A/19" vous fournira une cha�ne de 19 majuscules)

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Public Function GenerateStringAleaPattern(s As String, e As Boolean) As String
'create 1 String with pattern
Dim A, i As Long, j As Long, st As String, Nb As Long
    A = Split(s, "-")
    For i = 0 To UBound(A)
        Select Case Left$(A(i), 1)
            Case "A"
                Nb = CLng(Split(A(i), "/")(1)): j = 0
                Do
                    j = j + 1
                    st = st & Alea_Caract$(90, 65)
                    If Len(st) >= 2 And e Then
                        If Similar_Characters(st) Then st = Left$(st, Len(st) - 1): j = j - 1
                    End If
                Loop While j < Nb
            Case "a"
                Nb = CLng(Split(A(i), "/")(1)): j = 0
                Do
                    j = j + 1
                    st = st & Alea_Caract$(122, 97)
                    If Len(st) >= 2 And e Then
                        If Similar_Characters(st) Then st = Left$(st, Len(st) - 1): j = j - 1
                    End If
                Loop While j < Nb
            Case "9"
                Nb = CLng(Split(A(i), "/")(1)): j = 0
                Do
                    j = j + 1
                    st = st & Alea_Caract$(57, 48)
                    If Len(st) >= 2 And e Then
                        If Similar_Characters(st) Then st = Left$(st, Len(st) - 1): j = j - 1
                    End If
                Loop While j < Nb
            Case "!"
                Nb = CLng(Split(A(i), "/")(1)): j = 0
                Do
                    j = j + 1
                    st = st & Alea_Car_Spec$
                    If Len(st) >= 2 And e Then
                        If Similar_Characters(st) Then st = Left$(st, Len(st) - 1): j = j - 1
                    End If
                Loop While j < Nb
        End Select
    Next i
    GenerateStringAleaPattern = Shuffle_Letters(st)
End Function

Ces deux fonctions utilisent les fonctions suivantes :
Retourne un caract�re al�atoire, soit Majuscule, soit minuscule, soit num�rique :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
Private Function Alea_Caract(M As Long, L As Long) As String
'random 1 character in lower or upper case, or numeric
    Randomize Timer
    Alea_Caract = Chr$(Int(((M - L + 1) * Rnd) + L))
End Function

Retourne un caract�re sp�cial al�atoire :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
Private Function Alea_Car_Spec() As String
'random 1 character "special"
Const CHAINE = "!""#$%&'()*+,-./:;<=>?@[]_{|}~"
    Randomize Timer
    Alea_Car_Spec = Mid$(CHAINE, Int((Len(CHAINE) * Rnd) + 1), 1)
End Function

Rien de sp�cial, vide les 5 variables qui lui sont pass�es en argument :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
Private Sub Efface(t As String, A As Boolean, b As Boolean, C As Boolean, d As Boolean)
    t = vbNullString: A = False: b = False: C = False: d = False
End Sub

Permet l'exclusion d'un caract�re s'il est visuellement similaire � celui qui le pr�c�de :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
Private Function Similar_Characters(s As String) As Boolean
'option of excluding visually similar characters
Dim t, i As Long
Const COUPLES As String = "Il I1 l1 lI 1l 1I ]l l] 0O O0 5S S5 2Z 2? Z? Z2 ?2 ?Z DO OD"
    t = Split(COUPLES, " ")
    For i = 0 To UBound(t)
        If Right$(s, 2) = t(i) Then
            Similar_Characters = True: Exit For
        End If
    Next
End Function

M�lange les caract�res d'une cha�ne :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
Private Function Shuffle_Letters(s As String) As String
'shuffle the String's letters only if pattern
Dim i&, t, R As String, d() As Long
    t = Split(StrConv(s, vbUnicode), Chr$(0))
    d = Best_shuffle(UBound(t))
    For i = LBound(t) To UBound(t)
        R = R & t(d(i))
    Next i
    Shuffle_Letters = Left$(R, Len(R) - 1)
End Function

M�lange les indices d'un Array � 1 dimension : (L �tant l'UBound de l'array)

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Private Function Best_shuffle(L As Long) As Long()
Dim i As Long, ou As Long, temp() As Long
Dim C As New Collection
    ReDim temp(L)
    If L = 1 Then
        temp(LBound(temp)) = 0
    ElseIf L = 2 Then
        temp(LBound(temp)) = 1: temp(UBound(temp)) = 0
    Else
        Randomize
         i = LBound(temp)
        Do
            ou = Int(Rnd * L)
            On Error Resume Next
            C.Add CStr(ou), CStr(ou)
            If Err <> 0 Then
                On Error GoTo 0
            Else
                On Error GoTo 0
                temp(ou) = i
                i = i + 1
            End If
        Loop While C.Count <> L
    End If
    Best_shuffle = temp
End Function

Vous pouvez, � loisir, modifier les deux constantes :
1- Dans la Function Alea_Car_Spec()
Const CHAINE = "!""#$%&'()*+,-./:;<=>?@[]_{|}~"
2- Dans la Function Similar_Characters()
Const COUPLES As String = "Il I1 l1 lI 1l 1I ]l l] 0O O0 5S S5 2Z 2? Z? Z2 ?2 ?Z DO OD"

Enjoy it !

ComboBox : Rendre la saisie impossible si celle-ci ne figure pas dans la propri�t� List

pijaku — Fri, 14 Sep 2018 13:59:50 GMT

_______________________________________________________

Pr�ambule :

La question est :

Je souhaiterais emp�cher toute saisie si le texte entrant dans la ComboBox ne correspond pas � la liste initiale du contr�le.

Voici donc ce que je vous proposes...
Description du contr�le ComboBox :
Un contr�le ComboBox est compos� de deux �l�ments :

Une partie texte (similaire � un contr�le TextBox) qui est la zone de saisie du contr�le,
Une partie liste (similaire � un contr�le ListBox) qui est la zone de liste (d�roulante) de ce contr�le.

Cette description est � conserver dans un coin de votre m�moire, nous nous en servirons plus tard dans cette contribution.

Les propri�t�s int�ressantes :
La totalit� de ces d�tails sont issus de l'aide VBA (qui en comporte encore de nombreux, n'h�sitez pas � la consulter).
Je n'invente donc rien.

La propri�t� Style.
Pour un contr�le ComboBox, sp�cifie de quelle fa�on l'utilisateur va utiliser le contr�le.
Les valeurs de fmStyle sont les suivantes :

fmStyleDropDownCombo (Valeur : 0) : Le contr�le ComboBox se comporte comme une liste modifiable d�roulante.
L'utilisateur peut saisir une valeur dans la zone d'�dition ou en s�lectionner une dans la liste d�roulante (par d�faut).
fmStyleDropDownList (Valeur : 2) : Le contr�le ComboBox se comporte comme une zone de liste.
L'utilisateur doit choisir une valeur dans la liste.
La propri�t� MatchEntry.
Nous ne l'utiliserons pas ici, mais elle m�rite d'�tre connue.
Renvoie ou d�finit une valeur indiquant la fa�on dont un contr�le ListBox ou ComboBox fait des recherche dans ses listes pendant la saisie de l'utilisateur.

fmMatchEntryFirstLetter (Valeur : 0) : Correspondance de base. Le contr�le recherche l'entr�e suivante qui commence par le caract�re saisi.
La frappe r�p�t�e de la m�me lettre parcourt toutes les entr�es commen�ant par cette lettre.
fmMatchEntryComplete (Valeur : 1) : Correspondance �tendue.
Pour la frappe de chaque caract�re, le contr�le recherche une entr�e correspondant � tous les caract�res saisis (par d�faut).
fmMatchEntryNone (Valeur : 2) : Aucune correspondance.
La propri�t� MatchRequired.
Sp�cifie si une valeur saisie dans la partie texte d'un contr�le ComboBox doit correspondre � une entr�e de la partie liste existante du contr�le. L'utilisateur peut taper des valeurs non correspondantes, mais ne peut pas quitter le contr�le sans qu'une valeur correspondante soit saisie.
D�marche :
Premier cas : Utilisation de la liste comme une liste d�roulante modifiable, la propri�t� Style r�gl�e sur fmStyleDropDownCombo.
Ici, l�utilisateur peut saisir exactement ce qu�il souhaite.
Pour obtenir le r�sultat escompt� ici, il nous faut donc ajouter une autre propri�t� l�emp�chant de faire n�importe quoi. La propri�t� MatchRequired est id�ale pour cela : L'utilisateur peut taper des valeurs non correspondantes, mais ne peut pas quitter le contr�le sans qu'une valeur correspondante soit saisie.
Parfait !
Le code est donc :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
3
4
   With ComboBox1
      .Style = fmStyleDropDownCombo
      .MatchRequired = True
   End With
Ce code est fonctionnel, mais voil�, l�utilisateur se plaint qu�il n�y a pas de v�rification en cours de saisie et qu'en cas d'erreur, il ne le sait qu'� la fin...
Second cas : Utilisation de la liste comme une zone de liste, la propri�t� Style r�gl�e sur fmStyleDropDown.
Eh bien, dans ce cas, rien � ajouter. Le code est donc :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
3
   With ComboBox1
      .Style = fmStyleDropDownList
   End With
Le gros b�mol de cette m�thode r�side dans le fait que, d�s que l�utilisateur saisi un caract�re correct, la zone de texte est compl�t�e par le premier item correspondant dans la liste.
L�utilisateur ne visualise plus ou il en est de sa saisie.
Les contr�les ComboBox ne disposant pas des propri�t�s SelLenght et SelStart, ce souci ne peut �tre r�solu.
Particularit� � prendre en compte absolument :
Ces codes, extr�mement simples, ne sont pas applicables tels quels selon les types de donn�es entr�es dans la liste.
J�en reviens � ma description.
La zone de saisie renvoie syst�matiquement une donn�e de type String (VarType = 8).
La zone de liste, elle, est de type Variant/Variant (VarType = 8204 [8192 (Variant Tableau) + 12 (Variant)].
Lorsque cette liste contient des items num�riques, des dates, des valeurs de type Currency (etc�), le type de chacun de ses items est Variant/Type de l�item.
Soit, pour une date, de type Variant/Date.

Lors de l�utilisation des codes donn�s plus haut, si vos donn�es ne sont pas de type String, la comparaison entre la zone de texte et la zone de liste ne trouvera aucune correspondance.
Il convient donc, pour tous les types de donn�es cit�s ci-dessous, de convertir toute la liste avant de l�attribuer au contr�le ComboBox.

Types de donn�es � convertir absolument :
Integer
Long
Single
Double
Currency
Date
Byte
LongLong
Codes � appliquer pour ces cas :
Note : Je ne m�attarde pas ici sur les variables tableaux et utilise des bornes fig�es. A vous d�adapter cela � votre contexte.
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Private Sub UserForm_Activate()
Dim L(364) As String, v As Variant, i As Long
   ' transfert des données en mémoire
   v = Range("C1:C365").Value
   ' Conversion des données en String
   For i = 1 To 365
      L(i - 1) = v(i, 1)
   Next
   With ComboBox1
      .List = L
      .Style = fmStyleDropDownCombo
      .MatchRequired = True
   End With
End Sub
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub UserForm_Activate()
Dim L(364) As String, v As Variant, i As Long
   ' transfert des données en mémoire
   v = Range("C1:C365").Value
   ' Conversion des données en String
   For i = 1 To 365
      L(i - 1) = v(i, 1)
   Next
   With ComboBox1 
      .List = L
      .Style = fmStyleDropDownList
   End With
End Sub
Cas tr�s particulier :
L'alimentation du contr�le ComboBox via sa propri�t� rowSource.
Cela ne pose pas de probl�me pour des donn�es num�riques ou du texte. Les codes donn�s ci-dessus restent fonctionnels.
Cependant, si vous entrez, par cette propri�t�, des donn�es de type Date, dans votre ComboBox, ces codes ne fonctionneront pas, les Dates �tant stock�es sous forme num�rique dans la feuille.
Il existe tr�s certainement des petits soucis, dus principalement � une m�connaissance de l'utilisation de ce contr�le, mais vous devriez pouvoir satisfaire vos utilisateurs.
Certaines touches sont appr�ciables : Echap, fl�che vers le haut (ou vers le bas)...
:f1:

A bient�t
Franck

Le jeu du D�mineur

pijaku — Fri, 14 Sep 2018 13:49:01 GMT

________________________________________________

Bonjour,

Pas de blabla, du r�sul... Euh non, du code !

Aujourd'hui, un petit d�mineur sous UserForm.
Vous aurez besoin :
> d'un module de classe nomm� : ClassDemineur
> d'un module standard.

ATTENTION :
N�cessite de cocher les deux r�f�rences suivantes (Menu Outils/R�f�rences)
> Microsoft Forms 2.0 Object Library
> Microsoft Visual Basic For Applications Extensibility 5.3
Et : "acc�s approuv� au mod�le objet du projet VBA" doit �tre coch�e dans les options Excel.

Code du module de Classe :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
Option Explicit
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Nécessite de cocher les deux références suivantes (Menu Outils/Références)
    'Microsoft Forms 2.0 Object Library
    'Microsoft Visual Basic For Applications Extensibility 5.3
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
'Variables publiques
Public maForm As Object                                         'Userform
Public Fram As MSForms.Frame                                    'Frame = conteneur des boutons
Public Dico As Object                                           'Objet dictionary
Public DicoParent As Object                                     'Objet dictionary
Public Mine As Boolean                                          'Propriété Mine si True = bouton piégé
Public Decouverte As Boolean                                    'Propriété Découverte si True = "terrain(bouton) déminé"
'variables privées
Private Nom As String                                           'Nom => permet la construction et la destruction de l'userform
Private cVoisins() As ClassDemineur                                 'propriété sous forme de tableau listant les boutons voisins
'variables publiques "événementielles"
Public WithEvents Bouton As MSForms.CommandButton               'Bouton
'constantes
Private Const LARG_BTN As Byte = 18                             'taille des boutons
Private Const MIN_LIGN As Byte = 7                              'minimum de lignes
Private Const MAX_LIGN As Byte = 30 - MIN_LIGN                  'maximum de lignes
Private Const MIN_COL As Byte = 7                               'minimum de colonnes
Private Const MAX_COL As Byte = 40 - MIN_COL                    'maximum de colonnes
Private Const POURCENT_SIMPLE As Byte = 10                      '%age de mines en mode facile
Private Const POURCENT_MEDIUM As Byte = 2 * POURCENT_SIMPLE     '%age de mines en mode médium
Private Const POURCENT_HARD As Byte = 3 * POURCENT_SIMPLE       '%age de mines en mode difficile
Private Const COUL_MINE As Long = &H188B0                       'couleur des boutons minés (pour les dévoiler)
Private Const COUL_BOUTON As Long = &H8000000F                  'couleur des boutons
Private Const COUL_MINE_POSSIBLE As Long = &HFFFFFF             'couleur si bouton possiblement miné (bouton affiche ?) => doute
Private Const COUL_MINE_PROB As Long = &H8080FF                 'couleur si bouton probablement miné (bouton affiche !) => attention danger
 
Property Get Voisins() As ClassDemineur()                           'propriété de type tableau
'propriété Voisins en Lecture
   Voisins = cVoisins
End Property
 
Property Let Voisins(ByRef nouvVoisins() As ClassDemineur)
'propriété Voisins en Ecriture
   cVoisins = nouvVoisins
End Property
 
Private Sub Class_Initialize()
'constructeur de la classe cDémineur
   Set Dico = CreateObject("Scripting.dictionary")
End Sub
 
Public Sub Show(ByRef Difficult As Long, Optional ModeTriche As Boolean = False)
'Méthode Show : permet l'affichage de l'Userform
   On Error GoTo ErreurParametresMacros        'Vérification si "accès approuvé au modèle objet du projet VBA" est cochée dans les options Excel
   With ThisWorkbook.VBProject: End With
   On Error GoTo 0
   Dim Lign As Long, Col As Long, NbLignes As Long, NbColonnes As Long
   Dim NbMines As Long, MineAdress() As String, CptMine As Long
   Randomize Timer                             'initialisation générateur de nombres aléatoires
   NbLignes = Int(MAX_LIGN * Rnd) + MIN_LIGN   'Nombre de lignes de boutons
   NbColonnes = Int(MAX_COL * Rnd) + MIN_COL   'Nombre de colonnes de boutons
   Select Case Difficult                       'Nombre de Mines selon la difficulté choisie
      Case 0: Difficult = POURCENT_SIMPLE
      Case 1: Difficult = POURCENT_MEDIUM
      Case 2: Difficult = POURCENT_HARD
      Case Else: Exit Sub
   End Select
   NbMines = (NbLignes * NbColonnes) * Difficult \ 100
   ReDim MineAdress(NbMines)
   For CptMine = 1 To NbMines                 'coordonnées des Mines : Col-Lig
      MineAdress(CptMine) = Int(NbColonnes * Rnd) + 1 & "-" & Int(NbLignes * Rnd) + 1
   Next
   Call Creation_Usf("Démineur", (NbColonnes * LARG_BTN) + 5, (NbLignes * LARG_BTN) + 22)  'création Userfom
   Call Nouveau_Frame("Fram1", "", NbColonnes * LARG_BTN, NbLignes * LARG_BTN)             'création Frame
   For Lign = 1 To NbLignes                                                                'création Boutons
      For Col = 1 To NbColonnes
         'les noms des boutons : Col-Lig
         Call Dico("Fram1").Nouveau_Bouton(Col & "-" & Lign, "", LARG_BTN * (Col - 1), LARG_BTN * (Lign - 1), EstDans(Col & "-" & Lign, MineAdress), ModeTriche)
         Set Dico("Fram1").Dico(Col & "-" & Lign).DicoParent = Dico("Fram1").Dico
      Next Col
   Next Lign
   maForm.Tag = Timer  'stockage de l'heure de début de partie dans la propriété Tag de l'userform
   maForm.Show         'affichage du démineur
   Exit Sub
ErreurParametresMacros:
   MsgBox "Veuillez vérifier que vous avez approuvé l'accès au modèle objet du projet VBA."
End Sub
 
Private Sub Creation_Usf(Titre As String, Largeur As Double, Hauteur As Double)
'création Userfom
   Set maForm = ThisWorkbook.VBProject.VBComponents.Add(3)  'on ajoute au projet un module d'userform
   Nom = maForm.Name                                        'on prend son nom
   VBA.UserForms.Add (Nom)                                  'on ajoute l'userform au projet VBA
   Set maForm = UserForms(UserForms.Count - 1)              'on affecte cet userform à notre variable objet
   With maForm                                              'on lui affecte certaines propriétés
      .Caption = Titre                                      'titre
      .Width = Largeur                                      'largeur
      .Height = Hauteur                                     'hauteur
   End With
End Sub
 
Public Sub Nouveau_Frame(monNom As String, Titre As String, Largeur As Double, Hauteur As Double)
'création Frame
   If Dico.Exists(monNom) = True Then Exit Sub              'si déjà existant on quitte
   Dim maClass As New ClassDemineur                             'création d'une nouvelle instance de notre classe
   Set maClass.Fram = maForm.Controls.Add("forms.frame.1")  'Création d'un contrôle de type Frame
   Set maClass.maForm = maForm         'on affecte l'userform à la propriété "maForm" de notre instance de classe
   With maClass.Fram                   'on lui affecte certaines propriétés
      .Name = monNom                   'nom
      .Caption = Titre                 'titre
      .Move 0, 0, Largeur, Hauteur     'emplacement
   End With
   Dico.Add monNom, maClass            'on ajoute notre instance de classe au Dico
   Set maClass = Nothing
End Sub
 
Public Sub Nouveau_Bouton(monNom As String, Titre As String, Gauche As Double, Haut As Double, boolMine As Boolean, Optional ModeTriche As Boolean)
'création Boutons
   If Dico.Exists(monNom) = True Then Exit Sub                       'si déjà existant on quitte
   Dim maClass As New ClassDemineur                                      'création d'une nouvelle instance de notre classe
   Set maClass.Bouton = Fram.Controls.Add("forms.CommandButton.1")   'Création d'un contrôle de type Bouton
   Set maClass.maForm = maForm         'on affecte l'userform à la propriété "maForm" de notre instance de classe
   maClass.Mine = boolMine             'on définit la propriété Mine de notre bouton (True ou False)
   With maClass.Bouton                 'on définit certaines propriétés du bouton
      .Name = monNom                            'son nom
      .Caption = Titre                          'son Caption
      .Move Gauche, Haut, LARG_BTN, LARG_BTN    'son emplacement
      If ModeTriche Then                           'EN MODE TRICHE, COLORE LES BOUTONS MINES
         If boolMine Then .BackColor = COUL_MINE Else .BackColor = COUL_BOUTON
      Else
         .BackColor = COUL_BOUTON
      End If
   End With
   Dico.Add monNom, maClass            'on ajoute notre instance de classe au Dico
   Set maClass = Nothing
End Sub
 
Private Sub Bouton_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Procédure événementielle lors de l'appui, à l'aide d'un des 2 boutons de la souris, sur un Bouton de l'Userform
   If Button = XlMouseButton.xlSecondaryButton Then    'clic droit
      Select Case Bouton.Caption 'selon le Caption du bouton 4 possibilités
         Case "": Bouton.Caption = "!": Bouton.BackColor = COUL_MINE_PROB        'si caption est vide : on affiche ! (= attention danger)
         Case "!": Bouton.Caption = "?": Bouton.BackColor = COUL_MINE_POSSIBLE   'si caption est ! : on affiche ? (= doute)
         Case "?": Bouton.Caption = "": Bouton.BackColor = COUL_BOUTON           'si caption est ? : on affiche rien (= levée du doute)
         Case Else:                                                              'sinon (caption = chiffre (Nbre de mines voisines)) On ne fait rien
      End Select
   ElseIf Button = XlMouseButton.xlPrimaryButton Then  'clic gauche
      clic = clic + 1                                                            'incrémentation du compteur de clics gauches
      maForm.Caption = "Démineur - Nombre de coups joués : " & clic              'inscription du nombre de coups joués
      If DicoParent.Item(Bouton.Name).Mine Then                                  'si bouton miné
         Call Affiche_Toutes_Mines                                               'affichage de toutes les mines
         MsgBox "Partie perdue"                                                  'message PERDU !
         maForm.Hide                                                             'on quitte
      Else                                                                       'si bouton non miné
         Bouton.BackColor = COUL_BOUTON                                          'remet la couleur par défaut en cas de clic droit précédent
         Dim maClass As ClassDemineur                                                'on appelle la procédure de déminage
         Set maClass = DicoParent.Item(Bouton.Name)                              'procédure récursive de propagation
         Call Demine(maClass)                                                    'des boutons dont les voisins de sont pas des mines
      End If
   End If
   If Partie_Gagnee Then                                                         'lance la fonction Partie_Gagnee
      Call Affiche_Toutes_Mines                                                  'si victoire : affichage des mines et message:
      MsgBox "Félicitations" _
                & vbCrLf & "Partie Gagnée en : " & CInt(Timer - CDbl(maForm.Tag)) & " secondes." _
                & vbCrLf & "et en : " & clic & " coups joués.", vbOKOnly + vbExclamation, "GAGNE!"
      maForm.Hide                   'on quitte l'userform. Cela déclenche le destructeur de la classe
   End If
End Sub
 
Private Sub Affiche_Toutes_Mines()
'En cas de partie perdue, colore tous les boutons minés
   Dim cle
   For Each cle In DicoParent.keys 'boucle sur toutes les clés de notre DicoParent
   'celui-ci contient toutes les instances de la classe contenues dans le Frame
      'si l'instance de classe est minée => coloriage
      If DicoParent.Item(cle).Mine Then DicoParent.Item(cle).Bouton.BackColor = COUL_MINE
   Next
End Sub
 
Private Sub Demine(Cl As ClassDemineur)
'procédure récursive de propagation de la découverte des boutons non minés
   Dim NbMines As Integer
   NbMines = CompteMines(Cl.Bouton.Name)  'on teste le nombre de mines voisines
   If NbMines > 0 Then                    'si le bouton a au moins une mine parmi ses voisins
      Cl.Bouton.Caption = NbMines         'on affiche ce nombre de mines
      Cl.Decouverte = True                'on découvre ce bouton
   Else                                   'sinon
      If Cl.Decouverte = False Then       'Si le bouton n'est pas déjà découvert
         Cl.Decouverte = True             'on le découvre
         Cl.Bouton.Visible = False        'on rend la découverte visible par le joueur (=> le bouton disparait)
         Quels_Voisins Cl                 'on cherche qui sont les boutons voisins de ce bouton
         Dim tb() As ClassDemineur, i As Integer
         tb = Cl.Voisins
         For i = 0 To UBound(tb)          'on démine tous les boutons voisins (RECURSIVITE)
            Demine tb(i)
         Next
      End If
   End If
End Sub
 
Private Function CompteMines(Bout As String) As Integer
'fonction comptant les mines contenues dans les boutons voisins
   Dim i As Integer, j As Integer, Col As Integer, Lig As Integer
   Dim maClass As ClassDemineur
   For i = -1 To 1               'en incrémentant la colonne et la ligne de -1 à 1 on ne "vise" que les
      For j = -1 To 1            'boutons voisins de celui dont le nom est passé en paramètre
         Col = CInt(Split(Bout, "-")(0)) + i                   'incrémentation n° de colonne
         Lig = CInt(Split(Bout, "-")(1)) + j                   'incrémentation n° de ligne
         If DicoParent.Exists(Col & "-" & Lig) Then            'si le bouton existe (évite l'erreur de "débord" de l'userform)
            Set maClass = DicoParent.Item(Col & "-" & Lig)     'on attribue à notre variable le bouton voisin
            If maClass.Mine Then CompteMines = CompteMines + 1 's'il est miné on incrémente notre fonction de 1
         End If
      Next j
   Next i
End Function
 
Private Sub Quels_Voisins(Cl As ClassDemineur)
'procédure affectant, à la propriété Voisins() d'un bouton, la liste des boutons qui l'entourent
   Dim i As Integer, j As Integer, Col As Integer, Lig As Integer
   Dim maClass As ClassDemineur, ListeVoisins() As ClassDemineur, cpt As Byte
   For i = -1 To 1               'en incrémentant la colonne et la ligne de -1 à 1 on ne "vise" que les
      For j = -1 To 1            'boutons voisins de celui dont le nom est passé en paramètre
         Col = CInt(Split(Cl.Bouton.Name, "-")(0)) + i      'incrémentation n° de colonne
         Lig = CInt(Split(Cl.Bouton.Name, "-")(1)) + j      'incrémentation n° de ligne
         'si le bouton existe et que son nom est différent de celui passé en paramètre (on n'est pas son propre voisin ;-)
         If DicoParent.Exists(Col & "-" & Lig) And Cl.Bouton.Name <> Col & "-" & Lig Then
            Set maClass = DicoParent.Item(Col & "-" & Lig)  'on attribue à notre variable le bouton voisin
            ReDim Preserve ListeVoisins(cpt)                'redimensionnement variable tableau
            Set ListeVoisins(cpt) = maClass                 'on affecte notre instance de classe (bouton) au tableau
            cpt = cpt + 1
         End If
      Next j
   Next i
   Cl.Voisins = ListeVoisins        'on affecte la propriété Voisins de notre instance de classe (de notre bouton)
End Sub
 
Private Function Partie_Gagnee() As Boolean
   Dim cle
   Partie_Gagnee = False
   For Each cle In DicoParent.keys 'boucle sur toutes les clés de notre DicoParent
   '(donc sur toutes les instances de la classe, donc sur tous les boutons)
      'Si le bouton n'est pas "découvert" et qu'il ne contient pas de mine
      If DicoParent.Item(cle).Decouverte = False And DicoParent.Item(cle).Mine = False Then
         'alors la partie n'est pas finie
         Exit Function
      End If
   Next
   Partie_Gagnee = True
End Function
 
Private Function EstDans(adresse As String, tb) As Boolean
'fonction de recherche d'une valeur dans une var tableau
   Dim i As Long
   EstDans = False
   For i = 0 To UBound(tb) 'boucle sur toute la variable tableau passée en paramètre
      If tb(i) = adresse Then EstDans = True: Exit Function 'si on trouve l'élément cherché => fonction vraie, on sort
   Next i
End Function
 
Private Sub Class_Terminate()
'destructeur de la classe cDémineur
   Dim VBComp 'As VBComponent
   Set Dico = Nothing            'supprime toutes les instances de notre classe => tous les boutons
   If Nom <> "" Then             's'il s'agit de l'userform (seule instance ayant une propriété "Nom" remplie)
      Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom) 'on le cible
      ThisWorkbook.VBProject.VBComponents.Remove VBComp     'on le supprime
   End If
End Sub

Code d'appel dans le module standard :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Option Explicit
Public clic As Long
 
Sub Demineur()
  Dim MyForm As New ClassDemineur
  Dim rep As Integer, niveau As Long, Flag As Boolean
 
  clic = 0
  rep = MsgBox("Débutant ?", vbYesNo + vbQuestion, "Choix du niveau")
  If rep = vbYes Then
    niveau = 0
  Else
    rep = MsgBox("Intermédiaire ?", vbYesNo + vbQuestion, "Choix du niveau")
    niveau = IIf(rep = vbYes, 1, 2)
  End If
  'Flag = IIf(Feuil1.Range("A1") = "triche", True, False)
  MyForm.Show niveau, True
End Sub

Les deux param�tres pass�s � la classe d�terminent la difficult� (niveau) et si le Cheat Mode est activ� (ModeTriche = True)...

Bon jeu, et � ++
Franck

Acc�der aux �v�nements des contr�les ins�r�s dans une Frame plac�e dans une feuille de calcul

pijaku — Fri, 14 Sep 2018 13:42:30 GMT

________________________________________________________________

Introduction

L'int�r�t de cette contribution est multiple.
- La m�thode d'insertion de contr�les dans une Frame d'une feuille de calcul semble assez peu connue,
- Elle permet de cr�er des bo�tes de dialogue personnalis�es (MsgBox, InputBox particuli�res, Calendrier, Calculatrice, etc...) se substituant donc aux Userforms.
Mais alors, pourquoi vouloir substituer une Frame � l'Userform?
> question de positionnement sur la feuille de calcul,
> all�ger le code d'au moins un module (celui de l'Userform).

I- En mode cr�ation

Insertion de contr�les
La m�thode est tr�s simple.
1. Dessinez une Frame sur votre feuille :
  - Onglet d�veloppeur ==> cliquez sur le menu "Ins�rer"
  - Sous "contr�les Activex", cliquez sur "Autres contr�les" (ic�ne compos�e d'un marteau crois� � une cl�)
  - Recherchez et s�lectionnez le contr�le : Microsoft Forms 2.0 Frame
  - Cliquez sur OK, puis dessinez votre Frame.
2. Dans le Frame, effectuez un clic droit
3. S�lectionnez : Objet cadre>Edition
La bo�te � outils Contr�les s'affiche alors.
Vous pouvez maintenant dessiner tout type de contr�le dans votre Frame.
Pour l'exemple, nous allons dessiner une ComboBox et un CommandButton.

Associer des �v�nements
Une fois votre Frame remplie de ses contr�les, si l'on bascule sous l'�diteur VBA, on se rend compte que, dans le module de la feuille concern�e, le menu "g�n�ral" ne donne pas acc�s aux contr�les que nous venons de dessiner. En effet, ces deux contr�les (combobox et bouton de commande) sont inaccessibles par la feuille car dessin�s dans un autre container, notre Frame.
Ces contr�les �tant de type MSForms.XXX, nous pouvons d�clarer des variables de ce type avec activation des �v�nements.
En ent�te de Module, il nous suffit d'�crire :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
Option Explicit
 
Private WithEvents Combo1 As MSForms.ComboBox
Private WithEvents Bouton1 As MSForms.CommandButton

Dans le menu d�roulant "g�n�ral", nous avons maintenant acc�s � Bouton1 et Combo1 ainsi qu'� leurs �v�nements, dans le menu d�roulant "D�clarations".
Ne reste plus qu'� affecter � nos deux variables, nos deux contr�les.
Pour cela, dans l'�v�nement de votre choix, il suffit de les affecter comme ceci :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
Private Sub Worksheet_Activate()
    With Frame1
        Set Combo1 = .Controls("Combobox1")
        Set Bouton1 = .Controls("CommandButton1")
    End With
End Sub

Ajoutons-y, pour pousser un peu plus avant les tests, une propri�t� List � notre ComboBox :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
Private Sub Worksheet_Activate()
    With Frame1
        .Controls("Combobox1").List = Range("F1:F5").Value
        Set Combo1 = .Controls("Combobox1")
        Set Bouton1 = .Controls("CommandButton1")
    End With
End Sub

Ne reste plus qu'� cr�er vos propres proc�dures �v�nementielles, par exemple :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Option Explicit
 
Private WithEvents Combo1 As MSForms.ComboBox
Private WithEvents Bouton1 As MSForms.CommandButton
 
Private Sub Bouton1_Click()
    MsgBox Combo1.Text
End Sub
 
Private Sub Combo1_Change()
    Range("A1") = Combo1.Text
End Sub
 
Private Sub Worksheet_Activate()
    With Frame1
        .Controls("Combobox1").List = Range("F1:F5").Value
        Set Combo1 = .Controls("Combobox1")
        Set Bouton1 = .Controls("CommandButton1")
    End With
End Sub

II- Dynamiquement (At run time)

Le but ici est de cr�er dynamiquement un Frame, d'y ins�rer deux contr�les (1 CommandButton et 1 ComboBox) et de faire en sorte que ces deux contr�les r�agissent � leurs �v�nements.
Remarque : Avant de commencer, il nous faut noter que l'�v�nement d�clencheur est d�terminant. Si vous choisissez, par exemple, de cr�er votre Frame et ses contr�les par le clic sur un bouton ou par l'�v�nement Worksheet_Activate, il vous faut savoir que cela n�cessitera une autre proc�dure, secondaire (bouton en dehors du Frame ou Macro) pour affecter les variables "�v�nementielles" � vos contr�les.

Nous choisirons donc, pour plus de simplicit�, l'�v�nement Workbook_Open().
Cet �v�nement n'�tant pas celui d'une feuille de calcul, il nous faudra d�clarer quelques variables et constantes utiles en ent�te du module ThisWorkbook :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
Private Wsh As Worksheet '==> la feuille concernée
Private Const strSheetName As String = "Feuil1" '==> le nom de la feuille concernée
Private Const strFrameName As String = "MyFramePerso" '==> le nom de la frame à insérer
Private Const strComboName As String = "MyComboPerso" '==> le nom de la combobox à créer
Private Const strButtName As String = "MyButtonPerso" '==> le nom du bouton à créer

Ins�rer une Frame sur une feuille de calcul :
Une Frame, dans une feuille de calcul, appartient � la collection OLEObjects.
Nous allons donc d�clarer une variable de ce type. Cette variable va nous servir dans plusieurs proc�dures.
Si vous le souhaitez, vous pouvez donc la d�clarer en ent�te de module. J'ai fait le choix de la passer en param�tre des proc�dures concern�es.

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Sub Workbook_Open()
Dim Frm As OLEObject
    Set Wsh = Worksheets(strSheetName)
    InsertFrame Frm, Range("F20"), 200, 100
End Sub
 
Private Sub InsertFrame(F As OLEObject, rngCell As Range, W As Single, H As Single)
'insère une Frame sur la cellule référencée par rngCell
    Set F = Wsh.OLEObjects.Add("Forms.Frame.1")
    With F
        .Name = strFrameName
        .Height = H
        .Width = W
        .Left = rngCell.Left
        .Top = rngCell.Top
    End With
End Sub

A noter : Le param�tre rngCell repr�sente l'objet Range sur lequel nous allons positionner la Frame.

Cr�ation des contr�les dans la Frame :
Rien de bien compliqu�. Il faut juste savoir que l'on peut ajouter, � la propri�t� Object des objets OLEObject, un (des) contr�le(s) de type MSForms.Control, gr�ce � sa m�thode Add.

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Private Sub Workbook_Open()
Dim Frm As OLEObject
    Set Wsh = Worksheets(strSheetName)
    InsertFrame Frm, Range("F20"), 200, 100
    InsertControlsInFrame Frm
End Sub
 
Private Sub InsertControlsInFrame(F As OLEObject)
    With F
        With .Object.Add("Forms.ComboBox.1")
            .Name = strComboName
            .Top = 15
            .Left = 30
            .Height = 20
            .Width = 75
            .Object.Font.Name = "Arial"
            .Object.Font.Size = 12
            .Object.AddItem "Ananas"
            .Object.AddItem "Pomme"
            .Object.AddItem "Poire"
        End With
        With .Object.Add("Forms.CommandButton.1")
            .Name = strButtName
            .Top = 45
            .Left = 30
            .Height = 20
            .Width = 75
            .Object.Font.Name = "Arial"
            .Object.Font.Size = 12
            .Object.Caption = "BOUTON3"
        End With
        .Verb
    End With
End Sub

Remarque : En fin de code, la m�thode Verb est utilis�e pour que l'utilisateur puisse atteindre les contr�les. Sans cette m�thode, vous ne pourrez pas cliquer sur les contr�les de votre Frame.

Affecter les �v�nements aux contr�les :
Ici, avec une ComboBox et un CommandButton, nous nous contenterons du Click().
Pour cela, il nous faut, tout comme en mode cr�ation, d�clarer des variables "�v�nementielles".
Notre ent�te de module devient donc :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
Option Explicit
 
Private WithEvents Combo1 As MSForms.ComboBox
Private WithEvents Bouton1 As MSForms.CommandButton
 
Private Wsh As Worksheet
Private Const strSheetName As String = "Feuil1"
Private Const strFrameName As String = "MyFramePerso"
Private Const strComboName As String = "MyComboPerso"
Private Const strButtName As String = "MyButtonPerso"

Ensuite, cr�ons nos deux proc�dures �v�nementielles :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
Private Sub Bouton1_Click()
    MsgBox Combo1.Text
End Sub
 
Private Sub Combo1_Click()
    Range("A1") = Combo1.Text
End Sub

Et enfin, la proc�dure d'affectation des contr�les � ces variables :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
Private Sub Workbook_Open()
Dim Frm As OLEObject
    Set Wsh = Worksheets(strSheetName)
    InsertFrame Frm, Range("F20"), 200, 100
    InsertControlsInFrame Frm
    AffectVariables
End Sub
 
Private Sub AffectVariables()
    Set Combo1 = Wsh.OLEObjects(strFrameName).Object.Controls(strComboName)
    Set Bouton1 = Wsh.OLEObjects(strFrameName).Object.Controls(strButtName)
End Sub

On voit clairement dans cette proc�dure AffectVariables que les contr�les sont bien des membres de la propri�t� Object de l'objet OLEObject.

Code global � ins�rer dans le Module ThisWorkbook :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
Option Explicit
 
Private WithEvents Combo1 As MSForms.ComboBox
Private WithEvents Bouton1 As MSForms.CommandButton
 
Private Wsh As Worksheet
Private Const strSheetName As String = "Feuil1"
Private Const strFrameName As String = "MyFramePerso"
Private Const strComboName As String = "MyComboPerso"
Private Const strButtName As String = "MyButtonPerso"
 
Private Sub Bouton1_Click()
    MsgBox Combo1.Text
End Sub
 
Private Sub Combo1_Click()
    Range("A1") = Combo1.Text
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
    Wsh.Shapes.Range(Array(strFrameName)).Delete
End Sub
 
Private Sub Workbook_Open()
Dim Frm As OLEObject
    Set Wsh = Worksheets(strSheetName)
    InsertFrame Frm, Range("F20"), 200, 100
    InsertControlsInFrame Frm
    AffectVariables
End Sub
 
Private Sub InsertFrame(F As OLEObject, rngCell As Range, W As Single, H As Single)
    Set F = Wsh.OLEObjects.Add("Forms.Frame.1")
    With F
        .Name = strFrameName
        .Height = H
        .Width = W
        .Left = rngCell.Left
        .Top = rngCell.Top
    End With
End Sub
 
Private Sub InsertControlsInFrame(F As OLEObject)
    With F
        With .Object.Add("Forms.ComboBox.1")
            .Name = strComboName
            .Top = 15
            .Left = 30
            .Height = 20
            .Width = 75
            .Object.Font.Name = "Arial"
            .Object.Font.Size = 12
            .Object.AddItem "Ananas"
            .Object.AddItem "Pomme"
            .Object.AddItem "Poire"
        End With
        With .Object.Add("Forms.CommandButton.1")
            .Name = strButtName
            .Top = 45
            .Left = 30
            .Height = 20
            .Width = 75
            .Object.Font.Name = "Arial"
            .Object.Font.Size = 12
            .Object.Caption = "BOUTON3"
        End With
        .Verb
    End With
End Sub
 
Private Sub AffectVariables()
    Set Combo1 = Wsh.OLEObjects(strFrameName).Object.Controls(strComboName)
    Set Bouton1 = Wsh.OLEObjects(strFrameName).Object.Controls(strButtName)
End Sub

Conclusion :

Autres exemples :
Ces exemples correspondent aux divers t�tonnements qui m'ont amen� � cette contribution.
Il sont disponibles dans la discussion d'origine.

Extension aux autres logiciels Office :
Il en va de m�me pour tous les logiciels de la suite Office.
La diff�rence tiendra surtout dans les �v�nements d�clencheurs.
Voici deux petits exemples de code avec un Frame dessin� en mode cr�ation, dans lequel nous aurons plac� (m�me m�thode qu'au I-1.) un CommandButton.

Sous Powerpoint :
Ici l'�v�nement "d�clencheur" est le Frame1_GotFocus().

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
Option Explicit
 
Private WithEvents Bouton1 As MSForms.CommandButton
 
Private Sub Bouton1_Click()
    MsgBox "YES !!!"
End Sub
 
Private Sub Frame1_GotFocus()
    With Frame1
        Set Bouton1 = .Controls("CommandButton1")
    End With
End Sub

Ce code est � placer dans le Module du Slide concern�.

Sous Word :
Onglet d�veloppeurs, dans la rubrique contr�les cliquez sur Outils h�rit�s puis sur les Autres contr�les Activex.
Ici l'�v�nement "d�clencheur" est le Document_Open().

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
Option Explicit
 
Private WithEvents Bouton1 As MSForms.CommandButton
 
Private Sub Bouton1_Click()
    MsgBox "ça fonctionne!"
End Sub
 
Private Sub Document_Open()
    With Frame1
        Set Bouton1 = .Controls("CommandButton1")
    End With
End Sub

A noter sous Word, lors du clic droit dans le Frame, la pr�sence, dans l'objet cadre d'un Item "Convertir". Cela ne change rien au sujet dont il est question ici.

Un grand merci � Jacques (unparia) pour la relecture.

A bient�t,
Franck

Les diff�rentes m�thodes de d�termination d'un Range "utile"

pijaku — Fri, 14 Sep 2018 13:38:30 GMT

________________________________________________________________________________

Bonjour,

Je reviens pour un petit topo � propos des diff�rentes m�thodes de d�termination d'un Range "utile".

Avant tout, je tiens � pr�ciser qu'il ne s'agit pas ici de limite ou de lacune, mais plut�t de "pi�ges" � �viter.
Ces diff�rents pi�ges r�sident essentiellement dans les formatages :

Format de cellule,
Format de colonne (ligne) enti�re,
Lignes (colonnes) masqu�es,
Fusion de cellules.

Note : lorsque, dans ce topo, je parle de ligne, il en va de m�me pour les colonnes, et vice et versa...

---------------------------------------------------------------------------------------------------

La propri�t� CurrentRegion
L'aide VBA est tr�s claire � ce sujet :

Cette propri�t� renvoie un objet Range qui repr�sente la zone en cours. Celle-ci est une plage limit�e par toute combinaison de lignes et de colonnes vides. En lecture seule.

Autrement dit, elle retourne la plage des cellules adjacentes � l'objet Range renseign�.
Cette propri�t� n'est pas faite pour retourner la plage compl�te utilis�e dans une feuille, mais bel et bien pour retourner un Range limit�.
Si l'on a conscience de cela (pas de lignes ni de colonnes vides), il n'y a aucun pi�ge ni aucune lacune � cette propri�t�.

La propri�t� UsedRange
Ici, cette propri�t� ne s'applique plus � un Objet Range, mais � une feuille enti�re, l'Objet Worksheet.
Aide VBA :

Cette propri�t� renvoie un objet Range qui repr�sente la plage utilis�e dans la feuille de calcul sp�cifi�e. Propri�t� en lecture seule.

Tout formatage, m�me invisible (ex: Range("C17").Interior.Pattern = xlNone) fera inclure le Range format� au UsedRange.
Tout comme la propri�t� CurrentRegion, il n'y a pas de pi�ge � proprement parler, mais il vous faudra faire attention aux :

Format de cellule,
Format de colonne,
Lignes (colonnes) masqu�es,
Fusion de cellules.

La propri�t� SpecialCells
Comme presque syst�matiquement avec cette m�thode : � �viter!
L'aide VBA pr�cise que cette m�thode, utilis�e avec la Constante XlCellType :

xlCellTypeLastCell. Renvoie la derni�re cellule dans la plage utilis�e

Ouais...
Sauf si vous avez conscience que :

cette m�thode s'applique � la feuille enti�re,
l'enregistrement du classeur remet tout dans l'ordre

La propri�t� End --> xlDown et/ou xlUp
Aide VBA :

Cette propri�t� renvoie un objet Range qui repr�sente la cellule � la fin de la zone qui contient la plage source. Elle correspond aux combinaisons de touches CTRL+HAUT, CTRL+BAS. Objet Range en lecture seule.

Elle renvoie donc la derni�re ligne saisie sous le (xlDown) ou au dessus du (xlUp) Range indiqu�.
Attention donc aux lignes vides pour xlDown...
A noter �galement que cette propri�t� ne tient pas compte des lignes masqu�es sous le (ou au dessus du) Range renseign�, m�me si elles sont saisies (ce qui est le comportement normal de la combinaison de touches).

La m�thode find
A la base, elle n'est pas vraiment con�ue pour cela.
Mais, on peut tr�s bien l'utiliser dans certains cas, notamment parce qu'elle tient compte des lignes (colonnes) masqu�es.
Les pi�ges � �viter ici sont :

Les plages (colonnes et/ou lignes) vides,
Les cellules fusionn�es (beurk!).

Ces deux pi�ges vous renverront une Erreur d'ex�cution 91...

---------------------------------------------------------------------------------------------------

En conclusion, chacune des m�thodes expos�es ici s'adaptera � un cas pr�cis.
Ne pas chercher l'universalit�, mais profiter de cette diversit�.

A++
Franck

Limites et lacunes de VBA

pijaku — Fri, 14 Sep 2018 13:34:23 GMT

________________________________________________________________________________________________________________

Bonjour,

Comme chacun sait, Excel et VBA ont des sp�cifications, limites et lacunes.

En ce qui concerne Excel, je ne vais pas les lister dans le sens ou c'est tr�s bien fait ICI, du moins pour ce qui concerne les versions post�rieures � 2007.

Vous trouverez ICI les limites de chaque type de donn�es (Byte, Integer, Long, Currency, String,...).

Nous allons, dans ce sujet (re)d�couvrir et tenter de lister et r�soudre un maximum de celles de VBA.

Etant persuad� en avoir oubli�, n'h�sitez pas � me les indiquer en r�ponse pour que ce sujet soit le plus exhaustif possible.

________________________________________________________________________________________________________________

Le nombre maximum d'Areas dans une feuille
- Limite
  Ce nombre maximum est fix� � 8 192.
  Ce nombre correspond � la moiti� de la limite de la m�thode SpecialCells (cf plus bas) qui, vous en conviendrez, est fortement li�e � la notion d'Areas.
  A noter toutefois que ce nombre semble s'augmenter au fur et � mesure des tests, Excel "r�agissant" en effet sur ce sujet afin de s'adapter � la demande de l'utilisateur.
  Ainsi, un m�me utilisateur, sur un m�me pc, sans toucher � l'installation d'Office, peut voir ce maximum consid�rablement s'agrandir...
  Cela reste, pour moi, un des myst�res de MS Excel.
- Comment y pallier
  cf paragraphe ci-dessous, � propos de la m�thode SpecialCells.
Limite de la m�thode SpecialCells
- Limite
  Elle ne peut recenser d'un seul coup plus d'un certain nombre d'aires (Areas) r�sultant de son application.
  Ce nombre est �gal � la moiti� de la limite d'un type integer soit 16 385.
- Comment y pallier
  Lire la contribution d'unparia � ce sujet
Le nombre maximum d'�l�ments dans un Array
Ce nombre est limit� par la quantit� de m�moire disponible.
Il varie donc selon le type de donn�es contenues dans cet Array.
C'est pourquoi il est toujours vivement recommand� de bien typer toutes vos variables.

La division enti�re : \

Limite
Le plus grand nombre que l'on puisse diviser gr�ce � l'op�rateur \ est 2 147 483 647.
Il correspond � la limite du type Long.

Test :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
Sub Demo_Division_Entiere()
Dim d As Double, i As Double
   d = 2147483647
   MsgBox d \ 83647
   d = 2147483648#
   On Error Resume Next
   MsgBox d \ 2
   If Err.Number > 0 Then MsgBox Err.Description
   On Error GoTo 0
End Sub

Comment y pallier
Il suffit, pour cela, de prendre la partie enti�re de la division de deux Doubles.
Voici une fonction qui fait tr�s bien l'affaire, � titre d'exemple :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
Function Division_Entiere(Nb1 As Double, Nb2 As Double) As Double
   Division_Entiere = Int(Nb1 / Nb2)
End Function

Code appelant :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

MsgBox Division_Entiere(21474836489#, 12542)

A noter :
VBA n'�tant pas tr�s bien arm� pour les op�rations sur de grands nombres, la division de deux Double peut g�n�rer des erreurs...

Le Modulo : Mod

Limite
L'op�rateur Mod est limit� � 2 147 483 647.
Il correspond � la limite du type Long, tout comme pour la division enti�re.

Test :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
Sub Demo_Mod()
Dim d As Double
   d = 2147483647
   MsgBox d Mod 83647
   d = 2147483648#
   On Error Resume Next
   MsgBox d Mod 2
   If Err.Number > 0 Then MsgBox Err.Description
   On Error GoTo 0
End Sub

Comment y pallier
Tout comme pour la division enti�re, avec une petite fonction perso. Exemple :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
Function ModSansLimite(Nb1 As Double, Nb2 As Double) As Double
   ModSansLimite = Nb1 - (Int(Nb1 / Nb2) * Nb2)
End Function

Code appelant :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

MsgBox ModSansLimite(2147483648, 83647)

La m�thode WorksheetFunction.Match

Limite
La limite de cette m�thode est de 65 536, en ce qui concerne les variables tableaux.
Ce nombre correspond � la limites de lignes dans Excel 2003.
Cette limite n'existe plus si vous transf�rez votre tableau dans une feuille.

Test :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Demo_Match()
Dim t() As String, v, var As String, i As Long
   var = "liste21"
   ReDim t(65535)
   For i = LBound(t) To UBound(t)
      t(i) = "liste" & i
   Next
   v = Application.Match(var, t, 0)
   MsgBox v
   ReDim Preserve t(65536)
   t(65536) = "liste65536"
   On Error Resume Next
   v = Application.Match(var, t, 0)
   If Err.Number > 0 Then MsgBox Err.Description
   On Error GoTo 0
End Sub

Comment y pallier
Par une fonction personnelle.

Cette fonction perso va utiliser une fonction qui d�termine le nombre de dimensions d'un Array (Function Nb_Dimensions).
Fonction Nb_Dimensions (utile �galement dans le paragraphe sur Transpose (ci-dessous)) :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
Function Nb_Dimensions(ByRef Tableau As Variant) As Integer
'Retourne le nombre de dimensions d'une variable tableau
Dim d As Integer, t As Long
   On Error GoTo Fin
   Do
      d = d + 1
      t = UBound(Tableau, d)
   Loop
Fin:
   On Error GoTo 0
   Nb_Dimensions = d - 1
End Function

La fonction de "remplacement" de Match :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Function Get_Row(ByRef Tableau As Variant, ByRef Texto As Variant, Optional ByRef Colonne As Long) As Long
'Détermine l'index d'un élément à partir de son contenu
'Retourne un Long représentant l'index de cet élément
'Retourne -1 si l'élément n'existe pas dans le tableau ou erreur (de colonne, de Tableau, etc).
Dim i As Long, strTemp As String
   Get_Row = -1
   Select Case Nb_Dimensions(Tableau)
       Case 1
'===== le présent code, déposé par ucfoutu sur VBFrance, est la seule propriété de VBFrance
'=====VBFrance en autorise les libres copie et utilisation à la seule condition d'y laisser
'=====insérées les trois présentes lignes commentées --- ucfoutu ---
         strTemp = Chr(0) & Join(Tableau, Chr(0)) & Chr(0)
         i = InStr(strTemp, Chr(0) & Texto & Chr(0))
         If i = 0 Then
            Get_Row = -1
         Else
            strTemp = Mid(strTemp, 1, i)
            Get_Row = UBound(Split(strTemp, Chr(0))) - 1
            If Get_Row < 0 Then Get_Row = -1
         End If
'======================
      Case 2
         'si paramètre colonne omis, on prends la première
         If Colonne = 0 Then Colonne = LBound(Tableau, 2)
         For i = LBound(Tableau, 1) To UBound(Tableau, 1)
            If Tableau(i, Colonne) = Texto Then Get_Row = i: Exit For
         Next i
   End Select
End Function

A noter :
La m�me limite est fix�e en ce qui concerne la fonction Index (WorksheetFunction.Index).
Il est cependant beaucoup plus simple d'y rem�dier...

La m�thode Transpose

Limite
La limite de cette m�thode est de 65 536.
Tout comme Match et Index, ce nombre correspond � la limite de lignes dans Excel 2003.
A noter :
Transpose, �tant � la base une fonction de feuille de calcul, retourne un Array en Base 1 m�me si l'Array qui lui est inject� est en Base 0.
Notre fonction pour pallier � la limite de Transpose palliera �galement � cela.

Test :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub EssaiTranspose()
Dim t() As String, v, i As Long
 
   ReDim t(2, 65535)
   For i = LBound(t) To UBound(t)
      t(1, i) = "liste" & i
   Next
   v = Application.Transpose(t)
   MsgBox "Avec TRANSPOSE, cas < 65 536" & vbCrLf & vbCrLf & _
   "t : " & LBound(t, 1) & " To " & UBound(t, 1) & "  <=>  " & LBound(t, 2) & " To " & UBound(t, 2) & vbCrLf & _
    "v : " & LBound(v, 1) & " To " & UBound(v, 1) & "  <=>  " & LBound(v, 2) & " To " & UBound(v, 2)
   Erase v
   ReDim Preserve t(2, 66000)
   For i = 65536 To 66000
      t(1, i) = "liste" & i
   Next i
   On Error Resume Next
   v = Application.Transpose(t)
   If Err.Number > 0 Then MsgBox "Avec TRANSPOSE, cas > 65 536" & vbCrLf & vbCrLf & Err.Description
   On Error GoTo 0
End Sub

Comment y pallier
Il nous faut une fonction personnalis�e qui :
> transpose l'array
> le restitue dans la m�me base
Exemple (Attention : utilise la fonction Nb_Dimensions cf paragraphe pr�c�dent) :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Function Transposition(ByRef Tableau As Variant) As Variant
'Transpose une variable tableau à 2 dimensions
Dim tabl, i As Long, j As Long, c As Long
   Select Case Nb_Dimensions(Tableau)
      Case 1
         c = LBound(Tableau)
         c = IIf(c = 0, 1, 0)
         ReDim tabl(1 To UBound(Tableau) + c, 1 To 1)
         For i = 1 To UBound(tabl)
            tabl(i, 1) = Tableau(i - c)
         Next
      Case 2
         ReDim tabl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To UBound(Tableau, 1))
         For i = LBound(Tableau, 1) To UBound(Tableau, 1)
            For j = LBound(Tableau, 2) To UBound(Tableau, 2)
               tabl(j, i) = Tableau(i, j)
            Next j
         Next i
      Case Else
         MsgBox "Le tableau ne comporte pas une ou deux dimensions"
         Exit Function
   End Select
   Transposition = tabl
   Erase tabl
End Function

Code appelant :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
Dim t() As String, v, i As Long
   ReDim t(2, 66666)
   For i = LBound(t) To UBound(t)
      t(1, i) = "liste" & i
   Next
   v = Transposition(t)
   MsgBox "Avec Transposition, cas > 65 536" & vbCrLf & vbCrLf & _
   "t : " & LBound(t, 1) & " To " & UBound(t, 1) & "  <=>  " & LBound(t, 2) & " To " & UBound(t, 2) & vbCrLf & _
    "v : " & LBound(v, 1) & " To " & UBound(v, 1) & "  <=>  " & LBound(v, 2) & " To " & UBound(v, 2)

Limite de la m�thode Union

Lacunes
Deux lacunes sont � d�plorer au sujet de cette M�thode :
> Si un des arguments = Nothing elle engendre une erreur Argument ou appel de proc�dure incorrect
> Si deux Range s'intersectent, leurs cellules communes sont comptabilis�es 2 fois.

Test :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
Sub Demo_Union()
Dim Rng As Range, R As Range
   On Error Resume Next
   Set Rng = Application.Union(R, Range("A8:C10"), Range("B9:D11"))
   If Err.Number > 0 Then MsgBox Err.Description
   On Error GoTo 0
   Set Rng = Application.Union(Range("A8:C10"), Range("B9:D11"))
   MsgBox Rng.Address & "   " & Rng.Cells.Count
End Sub

Comment y pallier
Avec cette fonction :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Function UnionSansDoublons(ParamArray Rngs() As Variant) As Range
Dim RngTemp As Range, R As Range, i As Long
   For i = LBound(Rngs) To UBound(Rngs)
      If Not Rngs(i) Is Nothing Then
         If RngTemp Is Nothing Then
            Set RngTemp = Rngs(i)
         Else
            For Each R In Rngs(i).Cells
               If Application.Intersect(RngTemp, R) Is Nothing Then
                  Set RngTemp = Application.Union(RngTemp, R)
               End If
            Next R
         End If
      End If
   Next i
   Set UnionSansDoublons = RngTemp
End Function

Code appelant :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
Dim Rng As Range, R As Range
   Set Rng = UnionSansDoublons(R, Range("A8:C10"), Range("B9:D11"))
   MsgBox Rng.Address & "   " & Rng.Cells.Count

Limite de la fonction Join
La fonction Join comporte 2 d�fauts :

Elle ne fonctionne qu'avec un tableau de String (et/ou de Variant/Variant),
Elle ne fonctionne qu'avec des Arrays � une dimension.

Ces deux d�fauts, pris simplement, ne m�ritent pas forc�ment que l'on s'y attelle car ils sont tr�s ais�ment contournables en VBA.

Si l'on regarde de pr�s "l'�quivalant" de Join dans les formules Excel, on se rend compte que la fonction CONCATENER comporte �galement deux d�fauts :

Elle ne fonctionne pas avec des plages enti�res, ex : =CONCATENER(A1:C10),
On ne peut pas y int�grer un s�parateur, ex : =CONCATENER(A1;A2;"-")

Fort de ces 4 "d�fauts", je vous propose aujourd'hui une fonction qui va g�rer tout cela.

Note : une seconde fonction ICI prends en charge les formats de cellules...

Code de la fonction JOINT :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Public Function JOINT(ByRef Tableau As Variant, _
                        Optional ByRef RowSeparator As String = "", _
                           Optional ByRef ColumnSeparator As String = "", _
                              Optional ByRef ByRow As Boolean = True) As String
Dim st() As String, temp As Variant, maVar As Variant, i As Long, j As Long, d As Integer
   If TypeOf Tableau Is Excel.Range Then
      temp = Tableau.Value
   ElseIf IsArray(Tableau) Then
      temp = Tableau
   Else
      JOINT = "Erreur d'exécution '5' : " & vbCrLf & vbCrLf & _
               "Argument ou appel de procédure incorrect" & vbCrLf & _
                  "Argument incorrect : ByRef Tableau As Variant"
      MsgBox JOINT, vbOKOnly + vbCritical, "Microsoft Visual Basic"
      Exit Function
   End If
   On Error Resume Next
   Do While Err.Number = 0
      d = d + 1
      i = UBound(temp, d)
   Loop
   On Error GoTo 0
   Select Case d - 1
      Case 1: maVar = temp((UBound(temp) + LBound(temp)) \ 2)
      Case 2: maVar = temp((UBound(temp) + LBound(temp)) \ 2, LBound(temp))
      Case Else
         JOINT = "Erreur d'exécution '5' : " & vbCrLf & vbCrLf & _
               "Argument ou appel de procédure incorrect" & vbCrLf & _
                  "Argument incorrect : ByRef Tableau As Variant"
         MsgBox JOINT, vbOKOnly + vbCritical, "Microsoft Visual Basic"
         Erase temp
         Exit Function
   End Select
   Select Case VarType(maVar)
      Case 0, 2, 3, 4, 5, 6, 7, 8, 11, 12, 17
         Select Case d - 1
            Case 1
               ReDim st(LBound(temp) To UBound(temp)) As String
               For i = LBound(temp) To UBound(temp)
                  st(i) = temp(i)
               Next
               JOINT = Join(st, RowSeparator)
            Case 2
               If ByRow Then
                  ReDim st(LBound(temp, 1) To UBound(temp, 1)) As String
                  For i = LBound(temp, 1) To UBound(temp, 1)
                     For j = LBound(temp, 2) To UBound(temp, 2)
                        st(i) = st(i) & ColumnSeparator & temp(i, j)
                     Next
                     st(i) = Right(st(i), Len(st(i)) - Len(ColumnSeparator))
                  Next
                  JOINT = Join(st, RowSeparator)
               Else
                  ReDim st(LBound(temp, 1) To UBound(temp, 1)) As String
                  For i = LBound(temp, 2) To UBound(temp, 2)
                     For j = LBound(temp, 1) To UBound(temp, 1)
                        st(j) = temp(j, i)
                     Next
                     JOINT = JOINT & ColumnSeparator & Join(st, RowSeparator)
                  Next
                  JOINT = Right(JOINT, Len(JOINT) - Len(ColumnSeparator))
               End If
         End Select
         Erase st
      Case 20 'LongLong
      Case 1 'VbNull
         JOINT = "Erreur d'exécution '94' : " & vbCrLf & vbCrLf & _
                  "Utilisation incorrecte de Null"
         MsgBox JOINT, vbOKOnly + vbCritical, "Microsoft Visual Basic"
      Case Else 'Objet ou vberror ou autre...
         JOINT = "Erreur d'exécution '5' : " & vbCrLf & vbCrLf & _
                  "Argument ou appel de procédure incorrect"
         MsgBox JOINT, vbOKOnly + vbCritical, "Microsoft Visual Basic"
   End Select
   Erase temp
End Function

Exemples de code appelant :
Depuis VBA :

Code vba :

S�lectionner tout - Visualiser dans une fen�tre � part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Option Explicit
 
Sub Demonstration()
Const NB As Long = 100000
Dim Ra As Range, v, ll(1 To NB, 1 To 10) As Long, i As Long, j As Long, t As Double, dd(1 To NB, 1 To 10) As Double
Dim vt(1000000) As Long, d(1000000) As Double, da(1000000) As Date, errnull(1000) As Variant
Dim obj As Object
   Set obj = CreateObject("Scripting.dictionary")
   For i = LBound(vt) To UBound(vt)
      vt(i) = i
   Next
   For i = LBound(d) To UBound(d)
      d(i) = Timer
   Next
   For i = LBound(da) To UBound(da)
      da(i) = Now
   Next
   For i = LBound(errnull) To UBound(errnull)
      errnull(i) = Null
   Next
   Set Ra = Range("A1:J" & NB)
   Ra.Value = 10
   v = Ra.Value
   For i = 1 To NB
      For j = 1 To 10
         ll(i, j) = 10
      Next
   Next
   For i = 1 To NB
      For j = 1 To 10
         dd(i, j) = Timer
      Next
   Next
   Debug.Print "Erreurs : "
   Debug.Print JOINT(obj, ":", ";")
   Debug.Print "......................................"
   Debug.Print JOINT(errnull, ":", ";")
   Debug.Print ""
   Debug.Print "Test avec un Array à 1 dimension de 1 000 000 éléments."
   t = Timer
   Debug.Print TypeName(vt) & " : Longueur du String obtenu : " & Len(JOINT(vt, "/")) & " ==> " & Timer - t & " sec"
   t = Timer
   Debug.Print TypeName(d) & " : Longueur du String obtenu : " & Len(JOINT(d, "/")) & " ==> " & Timer - t & " sec"
   t = Timer
   Debug.Print TypeName(da) & " : Longueur du String obtenu : " & Len(JOINT(da, "/")) & " ==> " & Timer - t & " sec"
   Debug.Print ""
   Debug.Print "Test avec un Array à 2 dimensions de " & NB & " lignes et 10 colonnes."
   Debug.Print "ByRow............"
   t = Timer
   Debug.Print TypeName(Ra) & " : Longueur du String obtenu : " & Len(JOINT(Ra, "/", ":", True)) & " ==> " & Timer - t & " sec"
   t = Timer
   Debug.Print TypeName(v) & " : Longueur du String obtenu : " & Len(JOINT(v, "/", ":", True)) & " ==> " & Timer - t & " sec"
   t = Timer
   Debug.Print TypeName(ll) & " : Longueur du String obtenu : " & Len(JOINT(ll, "/", ":", True)) & " ==> " & Timer - t & " sec"
   t = Timer
   Debug.Print TypeName(dd) & " : Longueur du String obtenu : " & Len(JOINT(dd, "/", ":", True)) & " ==> " & Timer - t & " sec"
   Debug.Print ""
   Debug.Print "ByColumn............"
   t = Timer
   Debug.Print TypeName(Ra) & " : Longueur du String obtenu : " & Len(JOINT(Ra, "/", ":", False)) & " ==> " & Timer - t & " sec"
   t = Timer
   Debug.Print TypeName(v) & " : Longueur du String obtenu : " & Len(JOINT(v, "/", ":", False)) & " ==> " & Timer - t & " sec"
   t = Timer
   Debug.Print TypeName(ll) & " : Longueur du String obtenu : " & Len(JOINT(ll, "/", ":", False)) & " ==> " & Timer - t & " sec"
   t = Timer
   Debug.Print TypeName(dd) & " : Longueur du String obtenu : " & Len(JOINT(dd, "/", ":", False)) & " ==> " & Timer - t & " sec"
 
   Erase vt, d, da, ll, dd, v
   Ra.Clear
   Set Ra = Nothing
End Sub

Depuis une feuille de calcul :

=JOINT(A1:C10;;;VRAI)
=JOINT(A1:C10;;;FAUX)
=JOINT(A1:C10;"_";"|";VRAI)
=JOINT(A1:C10;"/";"|";FAUX)
....

Merci � vous, visiteurs, d'avoir lu ce billet.

A++
Franck

Utilisation du classeur Personal pour disposer, dans tous vos classeurs, de vos Fonctions, Sub et Classes

pijaku — Fri, 14 Sep 2018 13:23:17 GMT

_______________________________________________________________________________________________________

Bonjour,

Ayant d�couvert ceci r�cemment, je voulais vous en faire un petit r�sum� en retour...

L'int�r�t?
Pouvoir disposer, dans tous vos classeurs, de vos fonctions, proc�dures et classes favorites!

Comme beaucoup d'entres vous, j'utilises le classeur personal pour stocker des proc�dures et des fonctions VBA utiles.
Pour appeler ces proc�dures et fonctions depuis un classeur, ce n'est pas toujours ais�.

Voici les diff�rents processus.
Appeler une proc�dure :
Tout simplement en utilisant Run ou Application.Run.
En exemple, pour appeler la proc�dure nomm�e Macro1, situ�e dans le classeur Personal.xlsb :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
Application.Run "Personal.xlsb!Macro1"
Si la proc�dure Macro1 est une proc�dure param�tr�e, on passera les param�tres (max 30 arguments) comme ceci :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
Application.Run "Personal.xlsb!Macro1", Arg1, Arg2
Remarques : (extrait de l'aide VBA rubrique Application.Run, m�thode)
Vous ne pouvez pas utiliser d'arguments nomm�s avec cette m�thode. Ils doivent �tre transmis par position.
La m�thode Run renvoie ce que la macro ex�cut�e renvoie.
Appeler une fonction :
Un peu plus d�licat...
Il nous faut, tout comme pour n'importe qu'elle fonction d'une DLL, r�f�rencer le classeur personal.
Son nom, par d�faut, est VBAProject. Or il s'av�re que tout autre classeur poss�de son propre VBAProject.
En premier lieu, nous allons changer le nom du VBAProject du classeur personal.
Cliquez donc sur VBAProject (PERSONAL.XLSB) et modifiez le nom dans la fen�tre propri�t�s.
A titre personnel, j'ai choisit VBAProjectPersonal.
Dans le classeur depuis lequel vous souhaitez appeler une fonction de personal, ajoutez la r�f�rence :
Outils/R�f�rences... Cocher VBAProjectPersonal (ou le nom que vous avez choisi).

Vous pouvez maintenant appeler vos fonctions de la sorte :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
Dim B As Boolean
   B = VBAProjectPersonal.FeuilleExist("Classeur1", "Feuil1")
ou plus simplement encore :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
Dim B As Boolean
   B = FeuilleExist("Classeur1", "Feuil1")
Remarque :
Contrairement aux proc�dures (Sub) qui peuvent �tre Private, les fonctions (Function), au sein du classeur personal, doivent �tre Public pour �tre appel�es depuis un autre classeur.
Les modules de classe :
Sources : https://support.microsoft.com/en-us/help/555159

Nous allons cr�er, dans le classeur Personal.xlsb, une classe nomm�e ClassPersonne et y placerons ce code :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
3
4
5
6
7
8
9
Dim clsNom As String
 
Property Get Nom() As String
   Nom = clsNom
End Property
 
Property Let Nom(N As String)
   clsNom = N
End Property
Tr�s important : r�gler la propri�t� Instancing de votre Classe sur : 2- PublicNotCreatable.

Dans un module standard de votre classeur personal, vous allez cr�er cette fonction :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
3
Public Function New_Classe() As ClassPersonne
   Set New_Classe = New ClassPersonne
End Function
Dans le classeur depuis lequel vous souhaitez appeler une Classe de personal, ajoutez la r�f�rence :
Outils/R�f�rences... Cocher VBAProjectPersonal (ou le nom que vous avez choisi cf 2. plus haut).
Vous pouvez d�sormais utiliser votre classe, situ�e dans votre classeur personal, depuis n'importe quel classeur, comme ceci par exemple :
Code vba : S�lectionner tout - Visualiser dans une fen�tre � part
1
2
3
4
5
6
7
8
Sub Demo()
Dim Personne As VBAProjectPersonal.ClassPersonne
'ou Dim Personne As ClassPersonne
   Set Personne = VBAProjectPersonal.New_Classe
   ' ou Set Personne = New_Classe
   Personne.Nom = "TOTO"
   MsgBox Personne.Nom
End Sub
Je n'ai rien invent�, juste transmis le r�sum� de mes lectures.

Bonne journ�e.