Jeu du killer ou jeu du 12-30


Commenter

Contenu du snippet

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.

A voir également

S'inscrire maintenant

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.