nunuss7
Messages postés jeudi 15 juin 2006Date d'inscription
23 juin 2006
Dernière intervention
-
15 juin 2006 à 17:19 - Dernière réponse : nunuss7
Messages postés jeudi 15 juin 2006Date d'inscription
23 juin 2006
Dernière intervention
- 23 juin 2006 à 10:54
hello à tous,
je fais le jeu du moulin sur vba mais j'ai quelques problèmes..
quel serait le code afin de pouvoir déplacer un pion d'une case à l'autre..cependant un pion ne peut pas se déplacer sur toutes les cases occupées par un autre pion et sur certaine cases non accessibles.
voici le tableau des déplacements possibles à partir d'un pion(1ere colonne):
par exemple le pion 1 peut se déplacer sur la case 2 ou 10 si elles ne sont pas occupées.Si elles sont occupées impossible de sauter les cases 2 et 10 ou de les écraser. le pions ne peut donc pas bouger....
merci infiniment de vos réponses et de vos codes....
cs_bipou61
Messages postés mercredi 14 janvier 2004Date d'inscription
14 septembre 2006
Dernière intervention -16 juin 2006 à 17:09
+3
Utile
heu .... moi y en a pas connaitre ces objets là !
il serait bon de définir plusieurs choses avant de poser une question :
- définir le système sur lequel on travaille : VBA c'est encore vague (excel word, access, ...
- etre beaucoup plus précis dans les questions :
. qu'est-ce que tu as (cellules/controle,feuille excel/formulaire,...
. pour quel résultat
bon
dans le cas ou la liste des possiblité est fixe
je passerai par une fonction de ce type la:
function possibilite(case_depart as integer) as string
select case case_depart
case 1 : possibilite="2;10"
case 2 : possibilite="1;3;5"
...
...
case 24 : possibilite="15;23"
end select
end function
ce qui me renvoie une chaine que je peux convertir en tableau (split) des cases autorisées
Cette réponse vous a-t-elle aidé ?Merci pour votre retour.
N'oubliez pas de prendre quelques secondes pour remercier l'auteur : Merci pour votre retour.
Nous sommes désolés. Notre objectif est de vous donner la meilleure réponse possible.
cs_bipou61
Messages postés mercredi 14 janvier 2004Date d'inscription
14 septembre 2006
Dernière intervention -20 juin 2006 à 15:20
+3
Utile
j'ai deux solutions :
- je te donne le code (bof)
- je te dis ce qu'il faut faire sans le code (je préfére)
d'abord rajouter à ton type "tcaseMoulin" une donnée image (pour savoir quel n°image se trouve dessus) et une donnée propriétaire (qui est dessus)
j'ai rajouté aussi la chaine des triplés de cases gagnantes
Public Const str_gagne= "1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16;17;18;19;20;21;22;23;24;1;10;22;4;11;19;7;12;16;2;5;8;17;20;23;9;13;18;6;14;21;3;15;24"
pour pouvoir revenir en arrière, il faut sauvegarder les coordonnées origines de l'image que tu déplaces. (événement mouse_down)
dans l'événement mouse_up, il faut:
savoir de quel case provient le pion déplacé
savoir sur quel case il veut aller (ca c'est déjà fait)
savoir si la case est libre (c'est pour cela qu'il faut modifier ton type "tcaseMoulin")
savoir si le déplacement est autorisé (j'utilise ainsi la fonction que je t'ai déj envoyé) :
tab_poss = Split(possibilite(case_origine), ";")
For intJ = LBound(tab_poss) To UBound(tab_poss)
If tab_poss(intJ) intMin Then ok True
Next
si on n'a pas tout ca, on on revient aux coordonées de l'origine
sinon, on déplace puis on vérifie si on a un alignement
Function verif_gagne(joueur As Byte) As Boolean
Dim i As Integer
Dim c1 As Integer, c2 As Integer, c3 As Integer
Dim tab_gagne As Variant
verif_gagne = False
tab_gagne = Split(str_gagne, ";")
For i = LBound(tab_gagne) To UBound(tab_gagne) Step 3
c1 = arrcoorTableau(tab_gagne(i)).qui
c2 = arrcoorTableau(tab_gagne(i + 1)).qui
c3 = arrcoorTableau(tab_gagne(i + 2)).qui
If c1 c2 And c2 c3 And c1 = joueur Then verif_gagne = True: Exit For
Next
End Function
Cette réponse vous a-t-elle aidé ?Merci pour votre retour.
N'oubliez pas de prendre quelques secondes pour remercier l'auteur : Merci pour votre retour.
Nous sommes désolés. Notre objectif est de vous donner la meilleure réponse possible.
cs_bipou61
Messages postés mercredi 14 janvier 2004Date d'inscription
14 septembre 2006
Dernière intervention -21 juin 2006 à 15:35
+3
Utile
j'ai modifié:
Type tcaseMoulin
coorX As Integer
coorY As Integer
qui As Integer 'ajout bipou
imag As Byte 'ajout bipou
E
nd Type
Type coor 'ajout bipou
coorX As Integer 'ajout bipou
coorY As Integer 'ajout bipou
End Type 'ajout bipou
Public imag_orig As coor 'ajout bipou
j'ai modifié:
Private Sub Image5_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
imag_orig.coorX = Image5.Left
imag_orig.coorY = Image5.Top
End Sub
j'ai modifié
Sub MouseUp(NbImage As Byte)
Dim intMin As Integer
Dim intMinDist As Long
Dim intI As Integer
Dim intJ As Integer 'ajout bipou
Dim ok As Boolean 'ajout bipou
Dim tab_poss As Variant 'ajout bipou
Dim origine As Byte 'ajout bipou
origine = 0 'ajout bipou
ok = False 'ajout bipou
If (intJoueur = 1 And NbImage >= 5 And NbImage <= 13) Or _
(intJoueur = 2 And NbImage >= 14 And NbImage <= 22) Then
For intI = 1 To 24 'ajout bipou If arrcoorTableau(intI).imag NbImage Then origine intI 'ajout bipou
Next 'ajout bipou
intMin = 0
intMinDist = 9999999#
For intI = 1 To 24
If intMinDist > Sqr((arrcoorTableau(intI).coorX - Me.Controls("Image" & NbImage).Left) ^ 2 + (arrcoorTableau(intI).coorY - Me.Controls("Image" & NbImage).Top) ^ 2) Then
intMin = intI
intMinDist = Sqr((arrcoorTableau(intI).coorX - Me.Controls("Image" & NbImage).Left) ^ 2 + (arrcoorTableau(intI).coorY - Me.Controls("Image" & NbImage).Top) ^ 2)
End If
Next
If arrcoorTableau(intMin).qui <> 0 Then 'ajout bipou
Me.Controls("Image" & NbImage).Move imag_orig.coorX, imag_orig.coorY 'ajout bipou
Exit Sub 'ajout bipou
End If 'ajout bipou
If origine = 0 Then 'ajout bipou
ok = True 'ajout bipou
Else 'ajout bipou
tab_poss = Split(possibilite(origine), ";") 'ajout bipou
For intJ = LBound(tab_poss) To UBound(tab_poss) 'ajout bipou If tab_poss(intJ) intMin Then ok True 'ajout bipou
Next 'ajout bipou
End If 'ajout bipou
If ok Then 'ajout bipou
arrcoorTableau(intMin).qui = intJoueur 'ajout bipou
arrcoorTableau(intMin).imag = NbImage 'ajout bipou
Me.Controls("Image" & NbImage).Left = arrcoorTableau(intMin).coorX
Me.Controls("Image" & NbImage).Top = arrcoorTableau(intMin).coorY If origine <> 0 Then arrcoorTableau(origine).qui 0: arrcoorTableau(origine).imag 0 'ajout bipou
' MsgBox Moulin(intMin)
If verif_gagne(intJoueur) Then MsgBox "Joueur " & intJoueur & " a gagné": End 'ajout bipou
If intJoueur = 1 Then
intJoueur = 2
Else
intJoueur = 1
End If
Else
Me.Controls("Image" & NbImage).Move imag_orig.coorX, imag_orig.coorY 'ajout bipou
End If
End If
Me.TextBox1 = Me.Controls("TextBox" & 1 + intJoueur)
End Sub
j'ai modifié
function possibilite(case_depart as byte) as string
j'ai ajouté
Function verif_gagne(joueur As Byte) As Boolean 'ajout bipou
Dim i As Integer 'ajout bipou
Dim c1 As Integer, c2 As Integer, c3 As Integer 'ajout bipou
Dim tab_gagne As Variant 'ajout bipou
verif_gagne = False 'ajout bipou
tab_gagne = Split(str_gagne, ";") 'ajout bipou
For i = LBound(tab_gagne) To UBound(tab_gagne) Step 3 'ajout bipou
c1 = arrcoorTableau(tab_gagne(i)).qui 'ajout bipou
c2 = arrcoorTableau(tab_gagne(i + 1)).qui 'ajout bipou
c3 = arrcoorTableau(tab_gagne(i + 2)).qui 'ajout bipou If c1 c2 And c2 c3 And c1 = joueur Then 'ajout bipou
verif_gagne = True 'ajout bipou
Exit For 'ajout bipou
End If 'ajout bipou
Next 'ajout bipou
End Function 'ajout bipou
Cette réponse vous a-t-elle aidé ?Merci pour votre retour.
N'oubliez pas de prendre quelques secondes pour remercier l'auteur : Merci pour votre retour.
Nous sommes désolés. Notre objectif est de vous donner la meilleure réponse possible.
nunuss7
Messages postés jeudi 15 juin 2006Date d'inscription
23 juin 2006
Dernière intervention -18 juin 2006 à 12:12
0
Utile
le programme est sur vba excel...le tableau du dessus est une sur ma sheet3...
j'ai un frmtabledejeux sur lequel le jeu tourne...
le but du jeu est d'éliminer les pions adverses en faisant un moulin(charret)...les pions sont des simples images qu'on peut déplacer mais pour l'instant sur n'importe quelle autre case..le problème c'est que je ne sais pas comment faire pour que le pion se déplace seulement d'après les choix de cases du tableau défini sur excel...depplus un pions ne peut pas écraser un autre pion et il est impossible de sauter par dessus...
d'après la liste fixe que tu donne comment es ce que vba sait que c'est une liste sur ma page 3 d'excel?
For intI = 14 To 22
Me.Controls("image" & intI).Picture = Me.imgJoueur2R.Picture
Next
Case 2
Me.imgJoueur2F.Visible = False
Me.imgJoueur2B.Visible = False
Me.imgJoueur2Fr.Visible = True
Me.imgJoueur2R.Visible = False
Me.TextBox3.Value = "FRANKY"
Me.LabelJoueur2.Caption = "FRANKY"
For intI = 14 To 22
Me.Controls("image" & intI).Picture = Me.imgJoueur2Fr.Picture
Next
Case 3
Me.imgJoueur2F.Visible = False
Me.imgJoueur2B.Visible = True
Me.imgJoueur2Fr.Visible = False
Me.imgJoueur2R.Visible = False
Me.TextBox3.Value = "BIQUETTE"
Me.LabelJoueur2.Caption = "BIQUETTE"
For intI = 14 To 22
Me.Controls("image" & intI).Picture = Me.imgJoueur2B.Picture
Next
End Select
End Sub
Private Sub Image10_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 10, (x), (y), Button
End Sub
Private Sub Image10_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 10
End Sub
Private Sub Image11_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 11, (x), (y), Button
End Sub
Private Sub Image11_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 11
End Sub
Private Sub Image12_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 12, (x), (y), Button
End Sub
Private Sub Image12_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 12
End Sub
Private Sub Image13_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 13, (x), (y), Button
End Sub
Private Sub Image13_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 13
End Sub
Private Sub Image14_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 14, (x), (y), Button
End Sub
Private Sub Image14_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 14
End Sub
Private Sub Image15_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 15, (x), (y), Button
End Sub
Private Sub Image15_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 15
End Sub
Private Sub Image16_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 16, (x), (y), Button
End Sub
Private Sub Image16_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 16
End Sub
Private Sub Image17_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 17, (x), (y), Button
End Sub
Private Sub Image17_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 17
End Sub
Private Sub Image18_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 18, (x), (y), Button
End Sub
Private Sub Image18_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 18
End Sub
Private Sub Image19_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 19, (x), (y), Button
End Sub
Private Sub Image19_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 19
End Sub
Private Sub Image20_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 20, (x), (y), Button
End Sub
Private Sub Image20_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 20
End Sub
Private Sub Image21_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 21, (x), (y), Button
End Sub
Private Sub Image21_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 21
End Sub
Private Sub Image22_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 22, (x), (y), Button
End Sub
Private Sub Image22_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 22
End Sub
Private Sub Image5_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 5, (x), (y), Button
End Sub
Private Sub Image5_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 5
End Sub
Private Sub Image6_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 6, (x), (y), Button
End Sub
Private Sub Image6_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 6
End Sub
Private Sub Image7_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 7, (x), (y), Button
End Sub
Private Sub Image7_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 7
End Sub
Private Sub Image8_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 8, (x), (y), Button
End Sub
Private Sub Image8_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 8
End Sub
Private Sub Image9_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseMove 9, (x), (y), Button
End Sub
Private Sub Image9_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
MouseUp 9
End Sub
If intJoueur = 1 Then
intJoueur = 2
Else
intJoueur = 1
End If
Else
End If
End Sub
Function VerifieCase(bytCase As Byte) As Byte
Dim i As Integer
VerifieCase = cvide
For i = 5 To 13
If Me.Controls("Image" & i).Left = arrcoorTableau(bytCase).coorX And _
Me.Controls("image" & i).Top = arrcoorTableau(bytCase).coorY Then
VerifieCase = cJoueur1
End If
Next
For i = 14 To 22
If Me.Controls("Image" & i).Left = arrcoorTableau(bytCase).coorX And _
Me.Controls("image" & i).Top = arrcoorTableau(bytCase).coorY Then
VerifieCase = cJoueur2
End If
Next
End Function
Function Moulin(bytBut) As Byte
Dim i As Integer
Moulin = cvide
For i = 5 To 20
If ThisWorkbook.Sheets("Sheet3").Cells(i, 10) = bytBut Or _
ThisWorkbook.Sheets("Sheet3").Cells(i, 11) = bytBut Or _
ThisWorkbook.Sheets("Sheet3").Cells(i, 12) = bytBut Then
If VerifieCase(ThisWorkbook.Sheets("Sheet3").Cells(i, 10)) = cJoueur1 And _
VerifieCase(ThisWorkbook.Sheets("Sheet3").Cells(i, 11)) = cJoueur1 And _
VerifieCase(ThisWorkbook.Sheets("Sheet3").Cells(i, 12)) = cJoueur1 Then
Moulin = cJoueur1
End If
End If
Next
For i = 5 To 20
If ThisWorkbook.Sheets("Sheet3").Cells(i, 10) = bytBut Or _
ThisWorkbook.Sheets("Sheet3").Cells(i, 11) = bytBut Or _
ThisWorkbook.Sheets("Sheet3").Cells(i, 12) = bytBut Then
If VerifieCase(ThisWorkbook.Sheets("Sheet3").Cells(i, 10)) = cJoueur2 And _
VerifieCase(ThisWorkbook.Sheets("Sheet3").Cells(i, 11)) = cJoueur2 And _
VerifieCase(ThisWorkbook.Sheets("Sheet3").Cells(i, 12)) = cJoueur2 Then
Moulin = cJoueur2
End If
End If
Next
End Function
Function possibilite(case_depart As Integer) As String
Select Case case_depart
Case 1: possibilite = "2;10"
Case 2: possibilite = "1;3;5"
Case 3: possibilite = "2;15"
Case 4: possibilite = "5;11"
Case 5: possibilite = "2;4;6;8"
Case 6: possibilite = "5;14"
Case 7: possibilite = "8;12"
Case 8: possibilite = "5;7;9"
Case 9: possibilite = "8;13"
Case 10: possibilite = "1;22"
Case 11: possibilite = "4;10;12;19"
Case 12: possibilite = "7;11;16"
Case 13: possibilite = "9;14;18"
Case 14: possibilite = "6;13;15;21"
Case 15: possibilite = "3;14;24"
Case 16: possibilite = "12;17"
Case 17: possibilite = "16;18;20"
Case 18: possibilite = "13;17"
Case 19: possibilite = "11;20"
Case 20: possibilite = "17;19;21;23"
Case 21: possibilite = "14;20"
Case 22: possibilite = "10;23"
Case 23: possibilite = "20;22;24"
Case 24: possibilite = "15;23"
End Select
End Function
dans mes modules j'ai mis ca:
module1:
Option Explicit
Public choixA As Byte
Public choixB As Byte
Public nbrclick As Byte
Public intJoueur As Byte
Public Const cvide = 0
Public Const cJoueur1 = 1
Public Const cJoueur2 = 2
Type tcaseMoulin
coorX As Integer
coorY As Integer
End Type
Public arrcoorTableau(1 To 24) As tcaseMoulin
dans mon module2:
Sub Teste()
'
' Teste Macro
' Macro recorded 06.06.2006 by nussfabi
'
'
Sheets("Sheet2").Select
ActiveSheet.Shapes("flipper").Select
Selection.Copy
Sheets("Sheet3").Select
Range("C15").Select
ActiveSheet.Paste
End Sub
nunuss7
Messages postés jeudi 15 juin 2006Date d'inscription
23 juin 2006
Dernière intervention -21 juin 2006 à 15:08
0
Utile
merci infiniment du coups de main..j'ai encore 4 jours pour finir mon projet ca va etre court..je vais essayer ce que tu m as donné et j'espère que je vais y arriver....
pour les public les const et str gagné je dois les mettre dans un module? sous quel forme?
comment mets tu une image sur tmoulin?
cette partie:
tab_poss = Split(possibilite(case_origine), ";")
For intJ = LBound(tab_poss) To UBound(tab_poss) If tab_poss(intJ) intMin Then ok True
Next
va avec celle ci???:
function possibilite(case_depart as integer) as string
select case case_depart
case 1 : possibilite="2;10"
case 2 : possibilite="1;3;5"
...
...
case 24 : possibilite="15;23"
end select
end function
nunuss7
Messages postés jeudi 15 juin 2006Date d'inscription
23 juin 2006
Dernière intervention -23 juin 2006 à 10:54
0
Utile
merci infiniment pour ton aide...j'ai enfin pu finir le jeu meme si un bug de temps en temps mais rien de grave..juste que les moulins sont détectés sauf quelques fois..ton aide m'as été super utile...je te tire un grand coups de chapeau pour tes connaissances et surtout pour ta disponibilité...
ca fait plaisir de voir des gens comme toi qui aident les autres même des inconus...
