Discussion :

[hamboyzz]

Bonjour,

Avant de commencer, je précise que je suis totalement débutant sur le langage VBA.
Tout d'abord, j'aimerais concevoir un puissance 4 en langage VBA avec Excel 2013.
Suite à des multiples recherches et analyses sur des jeux de puissance 4, je n'arrive pas à faire glisser un pion dans une cellule de ma grille grâce à un bouton. J'ai essayé de m'inspirer sur les codes des différentes puissances 4 crée sur le forum mais je n'ai trouvé la réponse à ma question ni même un code qui pourrait m'aider.
Je m'explique:

Comme vous pouvez le voir sur l'image ci-dessous, j'aimerais que le bouton en forme de flèche fasse glisser un pion sur C11 soit Cells(11,3) en fonction du tour du joueur 1 ou 2:



Pour l'instant, en matière de macro dans mon code, j'ai une première macro NomJoueur qui permet d'affecter un pseudo pour les 2 joueurs ainsi que de determiner quel sera le joueur qui commencera. Voici le code de l'ensemble de ma macro:

Code :

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
Sub NomJoueur()
'
' NomJoueur Macro
'
    Range("Puissance4").ClearContents
 
    Dim Tourjoueur1 As Boolean
    Dim Tourjoueur2 As Boolean
    Dim Play As String
    Dim i As Byte
 
    For i = 1 To 7
        Cells(12, i + 2) = i
    Next i
 
    Tourjoueur1 = False
    Tourjoueur2 = False
 
    Range("K5") = InputBox("Pseudo du Joueur numéro 1")
        While Range("K5") = ""
            MsgBox ("Joueur 1, veuillez saisir un pseudo"), vbExclamation
            Range("K5") = InputBox("Pseudo du Joueur numéro 1")
        Wend
    Range("Q5") = InputBox("Pseudo du Joueur numéro 2")
        While Range("Q5") = ""
            MsgBox ("Joueur 2, veuillez saisir un pseudo"), vbExclamation
            Range("Q5") = InputBox("Pseudo du Joueur numéro 2")
        Wend
    Range("K7").Value = "Pion de " & Range("K5")
    Range("Q7").Value = "Pion de " & Range("Q5")
 
    Randomize
        If Int((2 * Rnd) + 1) = 1 Then
        Play = Range("K5")
        Range("A7").Font.Bold = True
        Cells(7, 1).Value = Range("K5") & ", à vous de jouer"
        Tourjoueur1 = True
        Tourjoueur2 = False
    Else
        Play = Range("Q5")
        Range("A7").Font.Bold = True
        Cells(7, 1).Value = Range("Q5") & ", à vous de jouer"
        Tourjoueur1 = False
        Tourjoueur2 = True
        End If
 
    MsgBox Play & ", Vous pouvez commencer la partie !", vbInformation
 
End Sub

J'ai pu un peu m'aider grâce à ces codes sources de jeux, même si c'était un peu dur :

https://office.developpez.com/defis/office/001/#LVI

Pouvez-vous m'aider s'il vous plait à trouver le bon code ou me donner des pistes relatives à ma recherche ?

Je vous remercie d'avance

[jean-marc flamand]

Bonjour

Voici un article expliquant le glisser et déposer un objet de type "Shape". Drag and Drop shapes.

L'autre option serait d'utiliser le symbole "2193" (flèche vers le bas) dans les cellules et les évènements "Worksheet_Change" et "Workbook_SheetSelection_Change" pour récupérer les adresses des cellules et de destination.


Bonne Journée

[ARTURO83]

Bonjour,

Une solution d'après les données fournies
Le résultat obtenu
Pièce jointe 511335

Le fichier
Pièce jointe 511339

Le code

Code :

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
266
Dim TourJoueur1 As Boolean
Dim TourJoueur2 As Boolean
Dim Player As String, Joueur As String, JoueurA As String, JoueurB As String
Dim Col As Long, DerLig As Long, NbBoulesJouees As Long
 
Sub Rangement_Des_Boules()
    Application.ScreenUpdating = False
    For i = 1 To 49
        If i Mod 2 = 0 Then
            With ActiveSheet.Shapes("Ellipse " & i)
                .Top = [S7].Top + 3
                .Left = [S7].Left + 3
                .Height = [S7].Height - 4
                .Width = [S7].Width - 4
            End With
        Else
            With ActiveSheet.Shapes("Ellipse " & i)
                .Top = [M7].Top + 3
                .Left = [M7].Left + 3
                .Height = [M7].Height - 4
                .Width = [M7].Width - 4
            End With
        End If
    Next i
End Sub
 
Sub Debuter_Nouvelle_Partie()
    Application.ScreenUpdating = False
    Rangement_Des_Boules
    If [K5] <> "" And [Q5] <> "" Then
        If MsgBox("Souhaitez-vous conserver les mêmes joueurs?", vbYesNo + vbCritical + vbDefaultButton2, "Joueurs") = vbNo Then Nom_Joueur
        Range("C5:I10").ClearContents
        Demarrer_la_partie
    End If
End Sub
 
Sub Nom_Joueur()
    Dim i As Byte
    Application.ScreenUpdating = False
    TourJoueur1 = False
    TourJoueur2 = False
    Range("K5") = InputBox("Pseudo du Joueur numéro 1")
        While Range("K5") = ""
            MsgBox ("Joueur 1, veuillez saisir un pseudo"), vbExclamation
            Range("K5") = InputBox("Pseudo du Joueur numéro 1")
        Wend
    Range("Q5") = InputBox("Pseudo du Joueur numéro 2")
        While Range("Q5") = ""
            MsgBox ("Joueur 2, veuillez saisir un pseudo"), vbExclamation
            Range("Q5") = InputBox("Pseudo du Joueur numéro 2")
        Wend
    Range("K7").Value = "Pion de " & Range("K5")
    Range("Q7").Value = "Pion de " & Range("Q5")
End Sub
 
Sub Demarrer_la_partie()
    Application.ScreenUpdating = False
    Randomize
    If Int((2 * Rnd) + 1) = 1 Then
        Player = Range("K5")
        Range("A7").Font.Bold = True
        TourJoueur1 = True
        TourJoueur2 = False
    Else
        Player = Range("Q5")
        Range("A7").Font.Bold = True
        TourJoueur1 = False
        TourJoueur2 = True
    End If
    [C2] = Player & ", à vous de jouer"
    MsgBox Player & ", Vous pouvez commencer la partie !", vbInformation
End Sub
 
Sub Fleche_1()
    If [C2] = "La partie est terminée" Then
        MsgBox "La partie est terminée, vous devez recommencer une nouvelle partie"
        Exit Sub
    End If
    Col = 3
    Descente
End Sub
 
Sub Fleche_2()
    If [C2] = "La partie est terminée" Then
        MsgBox "La partie est terminée, vous devez recommencer une nouvelle partie"
        Exit Sub
    End If
    Col = 4
    Descente
End Sub
 
Sub Fleche_3()
    If [C2] = "La partie est terminée" Then
        MsgBox "La partie est terminée, vous devez recommencer une nouvelle partie"
        Exit Sub
    End If
    Col = 5
    Descente
End Sub
 
Sub Fleche_4()
    If [C2] = "La partie est terminée" Then
        MsgBox "La partie est terminée, vous devez recommencer une nouvelle partie"
        Exit Sub
    End If
    Col = 6
    Descente
End Sub
 
Sub Fleche_5()
    If [C2] = "La partie est terminée" Then
        MsgBox "La partie est terminée, vous devez recommencer une nouvelle partie"
        Exit Sub
    End If
    Col = 7
    Descente
End Sub
 
Sub Fleche_6()
    If [C2] = "La partie est terminée" Then
        MsgBox "La partie est terminée, vous devez recommencer une nouvelle partie"
        Exit Sub
    End If
    Col = 8
    Descente
End Sub
 
Sub Fleche_7()
    If [C2] = "La partie est terminée" Then
        MsgBox "La partie est terminée, vous devez recommencer une nouvelle partie"
        Exit Sub
    End If
    Col = 9
    Descente
End Sub
 
Sub Descente()
    JoueurA = [K5]
    JoueurB = [Q5]
    DerLig = Cells(5, Col).End(xlDown).Row - 1
    NbBoulesJouees = Application.WorksheetFunction.CountA(Range("C5:I10"))
    ActiveSheet.Shapes("Ellipse " & NbBoulesJouees + 1).Select
    If Left([C2], Len(JoueurA)) = JoueurA Then
        Selection.ShapeRange.Fill.ForeColor.SchemeColor = 10 'Rouge
        Joueur = "JoueurA"
    Else
        Selection.ShapeRange.Fill.ForeColor.SchemeColor = 15 'Bleue
        Joueur = "JoueurB"
    End If
 
    With ActiveSheet.Shapes("Ellipse " & NbBoulesJouees + 1)
        .Top = Cells(4, Col).Top + 3
        .Left = Cells(4, Col).Left + 3
        .Height = Cells(4, Col).Height - 4
        .Width = Cells(4, Col).Width - 4
    End With
    Do While ActiveSheet.Shapes("Ellipse " & NbBoulesJouees + 1).Top < Cells(DerLig, Col).Top
        ActiveSheet.Shapes("Ellipse " & NbBoulesJouees + 1).Top = ActiveSheet.Shapes("Ellipse " & NbBoulesJouees + 1).Top + 5
        Tempo
        DoEvents
        ActiveSheet.Shapes("Ellipse " & NbBoulesJouees + 1).Top = ActiveSheet.Shapes("Ellipse " & NbBoulesJouees + 1).Top - 2
    Loop
    Cells(DerLig, Col) = Joueur
    If Joueur = "JoueurA" Then
        [C2] = JoueurB & ", à vous de jouer"
    Else
        [C2] = JoueurA & ", à vous de jouer"
    End If
    Controle
End Sub
 
Sub Tempo()
    For t = 1 To 100000
    Next
End Sub
 
Sub Controle()
    [C2].Activate
    If NbBoulesJouees + 1 < 7 Then Exit Sub
 
    'Contrôle horizontal
    l = DerLig
    c = Col
    Cpt = 0
    For c = Col - 3 To Col + 3
        If c > 2 And c < 10 Then
            If Cells(l, c) = Joueur Then Cpt = Cpt + 1 Else: Cpt = 0
            If Cpt = 4 Then
                MsgBox Player & " à gagné la partie en horizontal"
                [C2] = "La partie est terminée"
                End
            End If
        End If
    Next c
 
    'Contrôle vertical
    l = DerLig
    c = Col
    Cpt = 0
    For l = DerLig - 3 To DerLig + 3
        If l > 4 And l < 11 Then
            If Cells(l, c) = Joueur Then Cpt = Cpt + 1 Else: Cpt = 0
            If Cpt = 4 Then
                MsgBox Player & " à gagné la partie en vertical"
                [C2] = "La partie est terminée"
                End
            End If
        End If
    Next l
 
    'Contrôle diagonal de gauche à droite
    l = DerLig
    c = Col
    Cpt = 0
    For l = DerLig - 3 To DerLig + 3
        If l > 4 And l < 11 Then
            If c > 2 And c < 10 Then
                If Cells(l, c) <> "" Then
                    If Cells(l, c) = Joueur Then
                        Cpt = Cpt + 1
                        If Cpt = 4 Then
                            MsgBox Player & " à gagné la partie en diagonale de gauche à droite"
                            [C2] = "La partie est terminée"
                            End
                        End If
                        c = c + 1
                        GoTo LigneSuivante1
                    Else: Cpt = 0
                    End If
                Else
                    l = l + 1
                    c = c
                End If
            End If
        End If
LigneSuivante1:
    Next l
 
    'Contrôle diagonal de droite à gauche
    l = DerLig
    c = Col
    Cpt = 0
    For l = DerLig - 3 To DerLig + 3
        If l > 4 And l < 11 Then
            If c > 2 And c < 10 Then
                If Cells(l, c) <> "" Then
                    If Cells(l, c) = Joueur Then
                        Cpt = Cpt + 1
                        If Cpt = 4 Then
                            MsgBox Player & " à gagné la partie en diagonale de droite à gauche"
                            [C2] = "La partie est terminée"
                            End
                        End If
                        c = c - 1
                        GoTo LigneSuivante2
                    Else: Cpt = 0
                    End If
                Else
                    l = l + 1
                    c = c
                End If
            End If
        End If
LigneSuivante2:
    Next l
End Sub

Cdlt