Jeu de dés avec sons et possibilité de jouer à plusieurs et contre l'ordi, c'est à dire qu'il y a une espece d'intelligence artificielle et possibilité de choisir son niveau.
Regles du jeu completes sur wikipedia/ jeu du killer.
Source / Exemple :
Je mets le lien projet complet toute derniere version sans bugs(2 forms + 1 module + 1 repertoire de sons) car il depasse 1 Mo avec les sons:
http://download886.mediafire.com/b78ij5fxh1ug/8hxauobi7b7adj2/Jeu+du+killer2011.rar
Et voilà le code :
'Jeu du Killer par Julien V.
'Derniere mise à jour : 20/12/2011
'Code du form1 : le formulaire de jeu
Dim zexit As Boolean, lancer As Boolean, temporisation As Integer
Dim temporisationend(0 To 6) As Boolean, temps(0 To 5) As Integer
Dim debloque(0 To 5) As Boolean, nbbloc As Integer, peutlancer As Boolean
Dim attaque As Integer
Dim score(32) As Integer, scoretour(32, 100) As Integer, joueurstatut(32) As String
Dim ennemi(32) As Integer, deprebloque(5) As Boolean
Dim joueur As Integer, joueurattaque As Integer, forcelancer As Long
Dim boutonenfonce As Boolean, nbdead As Integer
Dim al As String, tour As Integer, nbchoisi As Integer, detop As Integer
Dim cptlight As Integer, best_attak As Integer, cptlightgraph As Integer, cptlightgraph2 As Integer
Dim best_attakant As Integer
Dim DX As New DirectX8
Dim DSEnum As DirectSoundEnum8
Dim DIS As DirectSound8
Dim DSSecBuffer(20) As DirectSoundSecondaryBuffer8
Dim DSSecBuffer2 As DirectSoundSecondaryBuffer8
Dim BuffDesc As DSBUFFERDESC
Dim cptsons As Integer
Dim cptballe As Integer
Private Sub BTexit_Click()
zexit = True
End
End Sub
Private Sub BTLancer_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Call play(0)
If peutlancer Then
lancer = True
Else
tmp = Int(Rnd * 7)
If tmp = 6 Then
peutlancer = True
lancer = True
Else
Text1 = "Tricherie : -1 point." & al & "1 chance sur 6 de ne pas se faire chopper."
score(joueur) = score(joueur) - 1
actu_score (joueur)
play (5)
End If
End If
If lancer Then
lbl_nomscore_Click (joueurattaque)
boutonenfonce = True
End If
End Sub
Private Sub BTLancer_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
boutonenfonce = False
End Sub
Private Sub Command1_Click() 'ouvre menu
Menu.Show
End Sub
Private Sub Command2_Click() 'affiche regles
MsgBox regle(0).nom & al & regle(0).libelle & al & regle(1).nom & al & regle(1).libelle
End Sub
Private Sub de_Click(Index As Integer)
If attaque = 0 And de(Index).Top > 0 Then
Call bloquede(Index)
End If
End Sub
Sub bloquede(Index As Integer) 'bloque dé
de(Index).BackStyle = 1
de(Index).BackColor = vbRed
If attaque = 0 Then
lbl_statut = "attend blocage ou lancer"
Else
lbl_statut = "lancer"
End If
If debloque(Index) = False Then
debloque(Index) = True
nbbloc = nbbloc + 1
peutlancer = True
play (9)
temporise (100)
End If
End Sub
Sub temporise(i As Integer)
If i = 0 Then Exit Sub
TimerSlow(6).Interval = i
temporisationend(6) = False
Do
DoEvents
Loop While temporisationend(6) = False
End Sub
Private Sub Form_Activate()
Dim taillepolice As Single
lbl_vitesse_Click (vitesse - 1)
actugraph
pbar.Width = 0
Do While zexit = False 'boucle tant que l'on ne veut pas quitter
If lancer And peutlancer And nbdead < nbjoueurs Then
lbl_statut = "lancer en cours"
peutlancer = False
For i = 0 To 5
If debloque(i) = False Then
de(i).Top = detop '2280
If Menu.CK_Detransp Then
de(i).ForeColor = KBcolor(joueur + 1)
de(i).BackColor = P_graph.BackColor
Else
de(i).BackColor = KBcolor(joueur + 1)
End If
de(i) = "*"
Else
de(i).BackColor = vbRed
End If
Next i
pbar.Width = 0
Do
For i = 0 To 5
If debloque(i) = False Then
Do
temp = Int(Rnd * 6) + 1
Loop Until temp <> de(i)
de(i) = temp
de(i).Refresh
End If
Next i
Call temporise(50 / vitesse)
DoEvents
If pbar.Width <= Me.BTLancer.Width Then
pbar.Width = pbar.Width + 200
Else
boutonenfonce = False
End If
Loop While boutonenfonce = True
aleades 'ou tirage
Else
If peutlancer = False Then lbl_statut = "attend blocage"
End If
If nbbloc = 6 And attaque = 0 Then 'debloque
tot = 0
For i = 0 To 5
'If debloque(i) Then nbbloc = nbbloc + 1
tot = tot + Val(de(i))
Next i
'Text1 = "total= " & tot & "." & al
Text1 = ""
Me.lbl_scorede.FontSize = 1
Me.lbl_scorede.Visible = True
Me.lbl_scorede = tot
'TimerSlow(6).Interval = 3000
For taillepolice = 1 To 100 Step vitesse * 4
Me.lbl_scorede.FontSize = taillepolice
temporise (40)
Next taillepolice
temporise (500)
Me.lbl_scorede.Visible = False
If tot < 12 Then
play (14)
attaque = 12 - tot
Text1 = Text1 & "Attaque au " & attaque & " !!!" & al & "Contre qui? "
lbl_statut = "choisir cible ou s'attaquer"
ElseIf tot > 30 Then
play (14)
attaque = tot - 30
Text1 = Text1 & "Attaque au " & attaque & " !!!" & al & "Contre qui? "
lbl_statut = "choisir cible ou s'attaquer"
Else
pt_perdu = tot - 12
If 30 - tot < pt_perdu Then pt_perdu = 30 - tot
If pt_perdu = 0 Then
For i = 0 To 5
de(i) = i + 1
de(i).BackColor = Me.P_graph.BackColor
Next i
j = -1
Dim tmp1 As Integer
aleasur6 = Int(Rnd * 7)
DoEvents
Me.lbl_statut = "temporise"
play (6)
For i = 0 To 12 + aleasur6
tmp1 = Int(i ^ 2.5) '+ 10
If tmp1 > 2500 Then tmp1 = 2500
If tmp1 < 100 Then tmp1 = 100
temporise (tmp1 / vitesse)
play (7)
j = j + 1
If j = 6 Then j = 0
de(j).BackColor = vbGreen
If j = 0 Then
de(5).BackColor = Me.P_graph.BackColor ' KBcolor(joueur + 1)
Else
de(j - 1).BackColor = Me.P_graph.BackColor 'KBcolor(joueur + 1)
End If
de(j).Refresh
Next i
Text1 = Text1 & lbl_nomscore(joueur) & " se soigne : +" & de(j) & " points"
score(joueur) = score(joueur) + Val(de(j))
actu_score (joueur)
Else
Text1 = Text1 & Me.lbl_nomscore(joueur) & " se blesse : -" & pt_perdu & " points!"
score(joueur) = score(joueur) - pt_perdu
actu_score (joueur)
End If
passemain
End If
For i = 0 To 5
debloque(i) = False
de(i).Top = detop '2280
de(i).BackColor = KBcolor(joueur + 1)
de(i) = "*"
Next i
nbbloc = 0
End If
DoEvents
Loop
End Sub
Sub aleades()
Dim tot_attak As Integer
forcelancer = 1 + pbar.Width * (10 / vitesse) / Me.Width
pbar.Width = 2
undeattaque = False
Text1 = ""
For i = 0 To 5
If debloque(i) = False Then
If Menu.CK_Detransp Then de(i).BackStyle = 0 Else de(i).BackStyle = 1
temporisation = Int(Rnd * 10) / vitesse + forcelancer
For j = 0 To temporisation
Do
temp = Int(Rnd * 6) + 1
Loop Until temp <> de(i)
de(i) = temp
'de(i).Refresh
de(i).Top = detop + j * 6000 / temporisation
TimerSlow(i).Interval = 25 + (j) * 6
temporisationend(i) = False
Do
DoEvents
Loop While temporisationend(i) = False
Next j
If Val(de(i)) = attaque Then
bloquede (i)
undeattaque = True
Else
play (8)
End If
End If
Next i
lancer = False
If peutlancer And attaque > 0 And nbbloc < 6 Then
Text1 = "Attaque encore"
Me.lbl_statut = "Attend lancer"
ElseIf attaque > 0 Then
temporise (2500 / vitesse)
For i = 0 To 5
If de(i) = attaque Then tot_attak = tot_attak + attaque
Next i
If tot_attak > 0 Then
If best_attak < tot_attak Then
play (3)
best_attak = tot_attak
best_attakant = joueur
lbl_best_attak = "Meilleur attaque : -" & best_attak & " à " & lbl_nomscore(joueurattaque)
lbl_best_attak.Top = lbl_nomscore(joueur).Top
lbl_best_attak.ForeColor = KBcolor(joueur + 1)
lbl_best_attak.Visible = True
End If
Text1 = "-" & Str(tot_attak) & " points à " & lbl_nomscore(joueurattaque) & "." '& al & "Joueur suivant."
score(joueurattaque) = score(joueurattaque) - tot_attak
temporise (1000 / vitesse)
Else
Text1 = lbl_nomscore(joueur) & " fait flop!" '& al & "Joueur suivant."
temporise (140 - vitesse * 3)
play (11)
temporise (300)
End If
Me.lbl_nomscore(joueurattaque).BackColor = KBcolor(joueurattaque + 1)
Me.lbl_score(joueurattaque).BackColor = KBcolor(joueurattaque + 1)
actu_score (joueurattaque)
temporise (1000 / vitesse)
attaque = 0
For i = 0 To 5
debloque(i) = False
de(i).Top = detop
de(i).BackColor = KBcolor(joueur + 1)
'de(i) = "*"
Next i
nbbloc = 0
peutlancer = True
passemain
End If
End Sub
Private Sub Form_Load()
detop = -de(0).Height
zexit = False
init_sons
al = Chr(13) & Chr(10)
For i = 1 To 6
Load TimerSlow(i)
Next i
'init et affiche score
attaque = 0
best_attak = 0
For i = 0 To nbjoueurs - 1
joueurstatut(i) = ""
score(i) = 30
scoretour(i, 0) = 30
scoretour(i, 1) = 30
If i > 0 Then
Load lbl_nomscore(i)
lbl_nomscore(i).Top = lbl_nomscore(i - 1).Top + lbl_nomscore(i).Height ' * 1.1
lbl_nomscore(i).Visible = True
Load Me.lbl_score(i)
lbl_score(i).Top = lbl_nomscore(i - 1).Top + lbl_nomscore(i).Height '* 1.1
lbl_score(i).Visible = True
End If
lbl_score(i).BackColor = KBcolor(i + 1)
lbl_nomscore(i).BackColor = KBcolor(i + 1)
lbl_nomscore(i) = Menu.TB_Nom(i)
lbl_score(i) = score(i)
lbl_nomscore(i).ForeColor = vbWhite
Me.lbl_score(i).ForeColor = vbWhite
ennemi(i) = -1
Next i
joueur = 0
lbl_nomscore(joueur).ForeColor = &HC000& 'Green
peutlancer = True
nbdead = 0
tour = 1
play (2)
If Menu.Cbo_typejoueur(joueur) = "I.A." Then
BTLancer.Visible = False
peutlancer = True
lancer = True
End If
For i = 0 To 5
de(i).Top = detop
'Me.de(i).BackColor = KBcolor(1)
debloque(i) = False
Next i
nbbloc = 0
End Sub
Sub actu_score(i As Integer)
On Error Resume Next
'For i = 0 To NbJoueurs - 1
playonce = True
If joueurstatut(i) <> "dead" Then
Dim monpas As Integer
monpas = Sgn((score(i) - Val(lbl_score(i))))
lbl_nomscore(i) = Menu.TB_Nom(i)
If monpas <> 0 Then
lbl_score(i).FontSize = 15
If monpas < 0 Then deb_boucle = Val(lbl_score(i)) - 1 Else deb_boucle = Val(lbl_score(i))
For decompte = deb_boucle To score(i) Step monpas
lbl_score(i) = decompte
lbl_score(i).Refresh
If monpas < 0 Then
play (1)
cptballe = cptballe + 1
If ShapeBalle.Count - 1 < cptballe Then Load Me.ShapeBalle(cptballe)
Me.ShapeBalle(cptballe).Left = Me.lbl_nomscore(i).Left + Rnd * (Me.lbl_nomscore(i).Width - Me.ShapeBalle(cptballe).Width)
Me.ShapeBalle(cptballe).Top = Me.lbl_nomscore(i).Top + Rnd * (Me.lbl_nomscore(i).Height - Me.ShapeBalle(0).Height)
Me.ShapeBalle(cptballe).Visible = True
Me.ShapeBalle(cptballe).ZOrder
lentemp = 120 + Int(Rnd * 1500 / (vitesse * 2))
temporise (lentemp)
Else
'If playonce = True Then
' play (6)
'End If
temporise (400 - vitesse * 10)
playonce = False
End If
'lentemp = Int((Rnd * 400) / vitesse)
'temporise (400 - vitesse * 10)
Next decompte
lbl_score(i).FontSize = 14
End If
lbl_score(i) = score(i)
scoretour(i, tour) = score(i)
Else
lbl_score(i) = "dead"
'nbdead = nbdead + 1
End If
If score(i) < -6 Then
joueurstatut(i) = "dead"
lbl_score(i) = "dead"
Me.lbl_score(i).ForeColor = vbRed
End If
'Next i
actugraph
End Sub
Sub actu_score_archive()
For i = 0 To nbjoueurs - 1
If score(i) < -6 Then
joueurstatut(i) = "dead"
Me.lbl_score(i).ForeColor = vbRed
End If
If joueurstatut(i) <> "dead" Then
lbl_nomscore(i) = Menu.TB_Nom(i)
lbl_score(i) = score(i)
scoretour(i, tour) = score(i)
Else
lbl_score(i) = "dead"
'nbdead = nbdead + 1
End If
Next i
actugraph
End Sub
Sub passemain()
Dim monstep As Integer
lbl_nomscore(joueur).ForeColor = vbWhite
'lbl_score(joueur).ForeColor = vbWhite
lbl_score(joueur).BackColor = KBcolor(joueur + 1)
joueurmem = joueur
Do
joueur = joueur + 1
cptlightgraph = 0
cptlightgraph2 = 0
'actugraph
If joueur > nbjoueurs - 1 Then
If Menu.CK_Gardimpact = False Then
On Error Resume Next
For balle = 1 To cptballe
Unload Me.ShapeBalle(balle)
Next balle
End If
joueur = 0
tour = tour + 1
play (4)
Me.lbl_tour = tour
nbdead = 0
For i = 0 To nbjoueurs - 1
scoretour(i, tour - 1) = score(i)
scoretour(i, tour) = score(i)
If score(i) < 0 Then
Select Case joueurstatut(i)
Case ""
joueurstatut(i) = "coma"
Me.lbl_score(i).ForeColor = vbRed
Case "coma"
joueurstatut(i) = "dead"
lbl_score(i) = "dead"
nbdead = nbdead + 1
'Text1 = Text1 & al & nbdead & " dead"
Case "dead"
nbdead = nbdead + 1
'lbl_score(i) = "dead"
End Select
Else
joueurstatut(i) = ""
Me.lbl_score(i).ForeColor = vbWhite
End If
Next i
'actugraph
End If
actugraph
'TB_Joueurencours = "a la main"'Me.lbl_nomscore(joueur)
monstep = (Me.lbl_nomscore(joueur).Top - TB_Joueurencours.Top) / (7 / vitesse)
For ytmp = TB_Joueurencours.Top To Me.lbl_nomscore(joueur).Top Step monstep
TB_Joueurencours.Top = ytmp 'Me.lbl_nomscore.Top
temporise (40)
Next ytmp
TB_Joueurencours.Top = Me.lbl_nomscore(joueur).Top
Loop Until nbdead >= nbjoueurs - 1 Or (joueurstatut(joueur) <> "dead" Or joueurmem = joueur)
'Call temporise(1000 / vitesse)
If nbdead >= nbjoueurs - 1 Then
Dim gagnant As Integer, scoretot As Integer
gagnant = -1
For i = 0 To nbjoueurs - 1
message = message & lbl_nomscore(i) & " : " & score(i) & al
If joueurstatut(i) <> "dead" Then
gagnant = i
scoretot = scoretot + score(i)
Else
scoretot = scoretot - score(i)
End If
Next i
If gagnant > -1 Then
phrase = lbl_nomscore(gagnant) & " gagne!" & al & "Score : " & scoretot
message = message & al & phrase & al
If best_attakant = gagnant Then
phrase = "Bonus Meilleur attaque :+" & best_attak
message = message & al & phrase
phrase = "Score total : " & best_attak + scoretot
message = message & al & phrase
End If
Else
message = message & al & "Match nul! Tous les joueurs sont morts!"
End If
joueur = gagnant
actugraph
play (13)
MsgBox message
Menu.Show
Exit Sub
End If
lbl_nomscore(joueur).ForeColor = &HC000& 'Green
joueurattaque = joueur
If Menu.Cbo_typejoueur(joueur) = "I.A." Then
Me.BTLancer.Visible = False
Else
Me.BTLancer.Visible = True
End If
'Text1 = Text1 & al & Chr(192) & " " & lbl_nomscore(joueur) & " de jouer."
lbl_statut = "Attend lancer"
End Sub
Private Sub lbl_nomscore_Click(Index As Integer)
dejarouge = False
If attaque > 0 Then
For i = 0 To nbjoueurs - 1
If lbl_nomscore(i).BackColor = vbRed Then dejarouge = True
Next i
If dejarouge = False And joueurstatut(Index) <> "dead" Then
play (15)
play (10)
lbl_nomscore(Index).BackColor = vbRed
lbl_score(Index).BackColor = vbRed
joueurattaque = Index
ennemi(joueurattaque) = joueur
Text1 = "Contre " & Me.lbl_nomscore(joueurattaque) & " !"
shap_attak.Visible = False
End If
End If
End Sub
Private Sub lbl_nomscore_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
dejarouge = False
For i = 0 To nbjoueurs - 1
If lbl_nomscore(i).BackColor = vbRed Then dejarouge = True
Next i
If attaque > 0 And joueurstatut(Index) <> "dead" And dejarouge = False Then
monstep = (Me.lbl_nomscore(cible).Top - shap_attak.Top) / (30 / vitesse)
shap_attak.Visible = True
If monstep <> 0 Then
For ytmp = shap_attak.Top To Me.lbl_nomscore(Index).Top Step monstep
shap_attak.Top = ytmp
'temporise (40)
Next ytmp
End If
shap_attak.Top = Me.lbl_nomscore(Index).Top
End If
End Sub
Private Sub lbl_statut_Change()
Dim monstep As Double
If Menu.Cbo_typejoueur(joueur) = "I.A." Then
Select Case lbl_statut
Case "Attend lancer"
temporise (500 / vitesse)
Call BTLancer_MouseDown(1, 0, 0, 0)
boutonenfonce = False
Case "attend blocage"
temporise (2000 / vitesse)
Dim nb(1 To 6) As Integer
For i = 0 To 5
'If debloque(i) = False Then
'If Val(de(i)) = 1 Then
dei = Val(de(i))
nb(dei) = nb(dei) + 1
'End If
Next i
If nbchoisi = 0 Then
If nb(1) + nb(6) > 0 Then
If nb(1) > nb(6) Then
nbchoisi = 1
Else
nbchoisi = 6
End If
Else
If nb(2) + nb(5) > 0 Then
If nb(2) > nb(5) Then
nbchoisi = 1
Else
nbchoisi = 6
End If
Else
nbchoisi = 6
End If
End If
End If
abloque = False
nbchoisimem = nbchoisi
If Menu.Cbo_niveaujoueur(joueur).ListIndex > 0 Then
som = 0
For i = 0 To 5
som = som + Val(de(i))
Next i
If som >= 30 And nbchoisi = 6 Then
For i = 0 To 5
If Menu.Cbo_niveaujoueur(joueur).ListIndex > 0 And nbbloc < 1 + Menu.Cbo_niveaujoueur(joueur).ListIndex Then
If debloque(i) = False And (Val(de(i)) > 1 Or Menu.Cbo_niveaujoueur(joueur).ListIndex > 1) Then
Call de_Click(Int(i))
abloque = True
End If
Else 'debutant
If debloque(i) = False And Val(de(i)) > 1 Then
Call de_Click(Int(i))
abloque = True
End If
End If
Next i
ElseIf som <= 12 And nbchoisi = 1 Then
For i = 0 To 5
If Menu.Cbo_niveaujoueur(joueur).ListIndex > 0 And nbbloc < 1 + Menu.Cbo_niveaujoueur(joueur).ListIndex Then
If debloque(i) = False And (Val(de(i)) < 6 Or Menu.Cbo_niveaujoueur(joueur).ListIndex > 1) Then
Call de_Click(Int(i))
abloque = True
End If
Else 'debutant
If debloque(i) = False And Val(de(i)) < 6 Then
Call de_Click(Int(i))
abloque = True
End If
End If
Next i
End If
End If
If abloque = False Then
Do
For i = 0 To 5
If debloque(i) = False Then
If Val(de(i)) = nbchoisi Then
If abloque = False Then
Call de_Click(Int(i))
abloque = True
Else
If Val(de(i)) = nbchoisimem Then Call de_Click(Int(i))
End If
End If
End If
Next i
If abloque = False Then
If Menu.Cbo_niveaujoueur(joueur).ListIndex > 0 Then ratio = 5 Else ratio = 4
If nbchoisimem = 6 Then
nbchoisi = nbchoisi - 1
If nbchoisi < 3 Then 'peut tricher
If Int(Rnd * ratio) = 1 Then
lbl_statut = "Attend lancer"
abloque = True
End If
End If
ElseIf nbchoisimem = 1 Then
nbchoisi = nbchoisi + 1
If nbchoisi > 4 Then 'peut tricher
If Int(Rnd * ratio) = 1 Then
lbl_statut = "Attend lancer"
abloque = True
End If
End If
End If
End If
Loop While abloque = False
End If
nbchoisi = nbchoisimem
If nbbloc < 6 Then
lbl_statut = "Attend lancer" 'arf
Else
nbchoisi = 0
End If
Case "choisir cible ou s'attaquer"
Dim cible As Integer
If nbbloc = 6 Then
lbl_statut = "Reflechi"
cible = joueur
shap_attak.Top = Me.lbl_nomscore(cible).Top
shap_attak.Visible = True
Dim alea As Integer
For hesitation = 0 To Rnd * 4
alea = Int(Rnd * 3)
If alea = 0 And ennemi(joueur) > -1 Then 'attaque ennemi 1 chance sur 2
cible = ennemi(joueur)
ElseIf alea = 1 Then 'attaque le plus haut score
leplushaut = -99
For joueurtmp = 0 To nbjoueurs - 1
If score(joueurtmp) > leplushaut And _
joueurtmp <> joueur And _
joueurstatut(joueurtmp) <> "dead" Then
leplushaut = score(joueurtmp)
cible = joueurtmp
End If
Next joueurtmp
Else
Do
cible = Int(Rnd * nbjoueurs)
Loop While cible = joueur Or joueurstatut(cible) = "dead" 'And zexit = False
End If
monstep = (Me.lbl_nomscore(cible).Top - shap_attak.Top) / (10 / vitesse)
If monstep <> 0 Then
For ytmp = shap_attak.Top To Me.lbl_nomscore(cible).Top Step monstep
shap_attak.Top = ytmp
temporise (200 / vitesse)
Next ytmp
End If
shap_attak.Top = Me.lbl_nomscore(cible).Top
temporise (700 / vitesse)
Next hesitation
shap_attak.Visible = False
'If cible = joueur Then MsgBox "Ouille !"
temporise (2000 / vitesse)
Call lbl_nomscore_Click(cible)
lbl_statut = "Attend lancer"
Else
MsgBox "what"
End If
End Select
End If
End Sub
Private Sub lbl_vitesse_Click(Index As Integer)
vitesse = Index + 1 'vitesse + 1
For i = 0 To Index
lbl_vitesse(i).BackColor = vbGreen
Next i
For i = Index + 1 To 8
lbl_vitesse(i).BackColor = vbWhite
Next i
'If vitesse = 10 Then vitesse = 1
'TB_vitesse = vitesse & "/9"
End Sub
Private Sub lbl_vitesse_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'If Button = 1 Then Call lbl_vitesse_Click(Index)
Call lbl_vitesse_Click(Index)
End Sub
Private Sub Text1_Change()
Text1.Top = detop
End Sub
Private Sub TimerLight_Timer()
Dim a As Double, b As Double
If Text1.Top < P_graph.Height / 4 Then Text1.Top = Text1.Top + 200
cptlight = cptlight + 1
If cptlight > 16 Then cptlight = 0
cptlightgraph2 = cptlightgraph2 + 1
If cptlightgraph2 >= (200 / tour) Then
cptlightgraph2 = 0
cptlightgraph = cptlightgraph + 1
If cptlightgraph = tour Then cptlightgraph = 0
End If
posx1 = P_graph.Width * cptlightgraph / tour
posy1 = P_graph.Height - P_graph.Height * (scoretour(joueur, cptlightgraph) + 50) / 100
posx2 = P_graph.Width * (cptlightgraph + 1) / tour
posy2 = P_graph.Height - P_graph.Height * (scoretour(joueur, cptlightgraph + 1) + 50) / 100
'Calcul a et b pour y=ax+b
a = (posy1 - posy2) / (posx1 - posx2)
b = posy1 - a * posx1
posx = P_graph.Width * (cptlightgraph + cptlightgraph2 / (200 / tour)) / tour
posy = a * posx + b
Shap_lightgraph.Left = posx - Shap_lightgraph.Width / 2
Shap_lightgraph.Top = posy - Shap_lightgraph.Height / 2
Shap_lightgraph.FillColor = KBcolor(joueur + 1)
Me.lbl_joueurencours = Menu.TB_Nom(joueur)
Me.lbl_joueurencours.Left = posx - lbl_joueurencours.Width / 2
Me.lbl_joueurencours.Top = Shap_lightgraph.Top - lbl_joueurencours.Height
Me.lbl_joueurencours.ForeColor = KBcolor(joueur + 1)
Select Case cptlight
Case 0
TB_Joueurencours.Visible = True
TB_Joueurencours.BackColor = KBcolor(joueur + 1)
'Me.lbl_joueurencours.Visible = True
Case 8
TB_Joueurencours.Visible = False
'Me.lbl_joueurencours.Visible = False
Case 1
shap_attak.Left = shap_attak.Left - 10
Case 2
shap_attak.Left = shap_attak.Left + 10
End Select
End Sub
Private Sub TimerSlow_Timer(Index As Integer)
temporisationend(Index) = True
End Sub
Sub actugraph()
Dim posx As Integer, posy As Integer
P_graph.Cls
P_graph.DrawWidth = 1
posy = P_graph.Height - P_graph.Height * 5 / 10
P_graph.Line (0, P_graph.Height - P_graph.Height * 5 / 10)-(P_graph.Width, posy), vbWhite
posy = P_graph.Height - P_graph.Height * (scoretour(joueurtmp, i) + 50) / 100
For joueurtmp = 0 To nbjoueurs - 1
If joueurtmp = joueur Then P_graph.DrawWidth = 5 Else P_graph.DrawWidth = 2
For i = tour To 0 Step -1 ' NbJoueurs - 1
posx = P_graph.Width * i / tour
posy = P_graph.Height - P_graph.Height * (scoretour(joueurtmp, i) + 50) / 100
'TXT = TXT & scoretour(joueurtmp, i) & " "
If i = tour Then
P_graph.PSet (posx, posy), KBcolor(joueurtmp + 1) 'vbWhite
Else
P_graph.Line -(posx, posy), KBcolor(joueurtmp + 1) 'vbWhite
End If
Next i
'P_graph.CurrentX = P_graph.Width * (tour - 0.5) / (tour)
'P_graph.CurrentY = P_graph.Height - P_graph.Height * (scoretour(joueurtmp, tour - 0.5) + 50) / 100
'raf : ecrire noms a cote des courbes graph
Next joueurtmp
End Sub
Sub play(son As Integer)
Dim BuffDesc As DSBUFFERDESC
Dim monchemin As String
If Menu.CK_son = False Then Exit Sub
Select Case son
'Case 0
' monchemin = "C:\WINDOWS\Media\ding.wav"
Case 1
monchemin = App.Path & "\sons\Coupdefeu.wav"
Case 2
monchemin = App.Path & "\sons\Coq.wav"
Case 3
monchemin = App.Path & "\sons\Photo.wav"
Case 4
monchemin = App.Path & "\sons\tic.wav"
Case 5
monchemin = App.Path & "\sons\keuf2.wav"
Case 6
monchemin = App.Path & "\sons\ambulance.wav"
Case 7
monchemin = App.Path & "\sons\tac.wav"
Case 8
monchemin = App.Path & "\sons\coup.wav"
Case 9
monchemin = App.Path & "\sons\coupmarteau2.wav"
Case 10
monchemin = App.Path & "\sons\coupmarteau1.wav"
Case 11
monchemin = App.Path & "\sons\flop.wav"
'Case 12
'monchemin = App.Path & "\sons\Clairon_attak.wav"
Case 13
monchemin = App.Path & "\sons\Clairon_mort.wav"
Case 14
monchemin = App.Path & "\sons\suspense_rlt_debut2.wav"
Case 15
monchemin = App.Path & "\sons\suspense_rlt_fin.wav"
End Select
IsPlaying = False
'Do
If DSSecBuffer(cptsons).GetStatus = DSBSTATUS_PLAYING Then
'IsPlaying = True
cptsons = cptsons + 1
If cptsons = 20 Then cptsons = 0 '=5 sons en meme temps maxi
' load the wave file, and create the buffer for it
'Set DSSecBuffer(cptsons) = DIS.CreateSoundBufferFromFile(monchemin, BuffDesc)
End If
'Loop While IsPlaying = True And cptsons < 20
Set DSSecBuffer(cptsons) = DIS.CreateSoundBufferFromFile(monchemin, BuffDesc)
DSSecBuffer(cptsons).play DSBPLAY_DEFAULT
End Sub
Sub init_sons()
'If Menu.CK_son = False Then Exit Sub
' get enumeration object
Set DSEnum = DX.GetDSEnum
' select the first sound device, and create the Direct Sound object
Set DIS = DX.DirectSoundCreate(DSEnum.GetGuid(1))
' Set the Cooperative Level to normal
DIS.SetCooperativeLevel Form1.hWnd, DSSCL_NORMAL
' allow frequency changes and volume changes
BuffDesc.lFlags = DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLVOLUME
Set DSSecBuffer(0) = DIS.CreateSoundBufferFromFile(App.Path & "\sons\Coq.wav", BuffDesc)
' volume is from 0 to -10,000 (where 0 is the lowdest, and -10,000 is silence)
DSSecBuffer(0).SetVolume -500
End Sub
_______________________________________________________________
'Formulaire Menu
Dim partieencours As Boolean
Private Sub BT_JOUER_Click()
Menu.Hide
Unload Form1
Load Form1
Form1.Visible = True
Form1.Text1 = regle(0).libelle
partieencours = True
End Sub
Private Sub Cbo_NbJoueurs_Click()
Cbo_NbJoueurs_LostFocus
End Sub
Private Sub Cbo_NbJoueurs_LostFocus()
If Val(Me.Cbo_NbJoueurs) > 8 Then
Cbo_NbJoueurs = 8
MsgBox "8 joueurs maximum dans cette version du jeu"
'nbjoueurs = Val(Me.Cbo_NbJoueurs)
ElseIf Val(Me.Cbo_NbJoueurs) < 2 Then
Cbo_NbJoueurs = 2
MsgBox "2 joueurs minimum"
'nbjoueurs = Val(Me.Cbo_NbJoueurs)
End If
On Error Resume Next
If partieencours Then
'reponse = MsgBox("Nouvelle partie !?", vbOKCancel)
'If reponse = 2 Then 'Annule
'Cbo_NbJoueurs = nbjoueurs
'Exit Sub
'End If
Unload Form1
End If
nbjoueurs = Val(Me.Cbo_NbJoueurs)
For i = 1 To 7
If i <= Val(Me.Cbo_NbJoueurs) - 1 Then
nouvotop = lbl_num(i - 1).Top + lbl_num(i - 1).Height
'Load Me.lbl_num(i)
lbl_num(i).Visible = True
lbl_num(i).Top = nouvotop
lbl_num(i) = i + 1
'Load Me.TB_Nom(i)
TB_Nom(i).Visible = True
TB_Nom(i).Top = nouvotop
Me.TB_Nom(i) = "Joueur " & i + 1
'Load Me.Cbo_typejoueur(i)
Cbo_typejoueur(i).Visible = True
Cbo_typejoueur(i).Top = nouvotop
Cbo_typejoueur(i) = "I.A."
'Cbo_typejoueur(i).Enabled = False
'Load Me.Cbo_niveaujoueur(i)
Cbo_niveaujoueur(i).Top = nouvotop
If Cbo_typejoueur(i) = "I.A." Then
Cbo_niveaujoueur(i).Visible = True
Else
Cbo_niveaujoueur(i).Visible = False
End If
'Cbo_niveaujoueur(i).Clear
Else
lbl_num(i).Visible = False
TB_Nom(i).Visible = False
Cbo_typejoueur(i).Visible = False
Cbo_niveaujoueur(i).Visible = False
End If
Next i
Me.TB_Nom(1) = "Six Killer"
Me.TB_Nom(2) = "John Brain"
Me.TB_Nom(3) = "Dédé"
Me.TB_Nom(0).SetFocus
Me.TB_Nom(0).SelLength = Len(Me.TB_Nom(0))
End Sub
Private Sub Cbo_typejoueur_Click(Index As Integer)
If Cbo_typejoueur(Index) = "Humain" Then
Cbo_niveaujoueur(Index).Visible = False
Else
Cbo_niveaujoueur(Index).Visible = True
End If
'Call Cbo_NbJoueurs_Click
End Sub
Private Sub Form_Load()
Randomize
For i = 0 To 7
If i > 0 Then
Load Me.lbl_num(i)
Load Me.TB_Nom(i)
Load Me.Cbo_typejoueur(i)
Load Me.Cbo_niveaujoueur(i)
Cbo_NbJoueurs.AddItem i + 1
End If
lbl_num(i).BackColor = KBcolor(i + 1)
Cbo_typejoueur(i).AddItem "Humain"
Cbo_typejoueur(i).AddItem "I.A."
Cbo_niveaujoueur(i).AddItem "0:debutant ou mystique"
Cbo_niveaujoueur(i).AddItem "1:niveau primaire"
Cbo_niveaujoueur(i).AddItem "2:niveau supérieur"
Cbo_niveaujoueur(i).AddItem "3:calcul de probabilite"
Cbo_niveaujoueur(i) = "1:niveau primaire"
Next i
Cbo_NbJoueurs.ListIndex = 0
Cbo_typejoueur(0).ListIndex = 0
nbjoueurs = 2
End Sub
Private Sub Form_Paint()
Me.TB_Nom(0).SetFocus
Me.TB_Nom(0).SelLength = Len(Me.TB_Nom(0))
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
_____________________________________
'Module1
Type condition
aleade As Integer
de(0 To 5) As Boolean
valeur(0 To 5) As Integer '
End Type
Type regle
nom As String
libelle As String
moment As String 'selon score ou selon resultat attaque
condition As condition
points As Integer 'fait gagner ou fait perdre
joueur As Integer '1->joueur 2->joueur attaqué 99->tous les joueurs
debase As Boolean 'si true: regle de base qu'on ne peut supprimer
End Type
Public condition As condition
Public regle(999) As regle
Public nbregles As Integer
Public vitesse As Integer
Public KBcolor(32) As Long
Public nbjoueurs As Integer
Sub main()
'regle1 = "Le jeu du Killer. Faites moins de 12 ou plus de 30 en gardant au moins un dé après chaque lancer"
nbregles = 0
regle(0).nom = "Pour attaquer"
regle(0).libelle = "Faites moins de 12 ou plus de 30 en gardant au moins un dé après chaque lancer"
regle(1).nom = "Pour ne pas perdre"
regle(1).libelle = "Restez dans le positif, ou un tour maximum dans le négatif. Si votre score est plus bas que -6 : vous êtes dead aussi "
For i = 1 To 15
KBcolor(i) = QBColor(i)
Next i
KBcolor(1) = RGB(250, 200, 100) 'orange
KBcolor(2) = RGB(255, 195, 225) 'rose RGB(120, 162, 100) 'beau vert
KBcolor(7) = RGB(75, 200, 211) 'beau vert
Load Menu
Menu.Visible = True
vitesse = 1
End Sub
Conclusion :
Le visuel pourrait être amélioré... Genre dé en 3d d'après une source de cube 3d trouvé sur ce site.
Merci de me faire part de remarques, bugs, améliorations, idées,... c'est cool.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.