Compte à rebours dans un userform avec conditions

Le 23/01/2013 à 08:25

Bonjour,

Dans mon dossier "Concours hippique", j'ai un userform1 qui gére les données de la compétition.

Dans ce userform j'ai déja un chrono pour le tour et je souhaite ajouter un compte à rebours de 45s à 0s qui va s'afficher sur mon label chrono2

Voici sa fonction :

Le cavalier se présente devant le juge si ok le juge lance une sonnerie " ici macro Son3 "

ici par CommandButton10_Click() et cela doit donc déclencher automatiquement ma macro Son3 "sonnerie" ainssi que le départ de mon compte à rebour.

Ensuite le cavalier a 45s pour prendre le départ

2 conditions :

1/ Il prend le départ avant la fin du compte à rebours alors

Automatiquement compte à rebours a 0 et lance le chrono tour ici par BTN_Depart_Click() de mon userform1

2/ Il prend le départ aprés le 00:00: alors "éliminé" et donc les boutons du chrono enable et report donnée en

Range("Y" & Ligne) = 100

Range("AA" & Ligne) = "Eliminé(e)"

En fin de tour RAZ par BTN_RAZ_Click()

Voila mon usine à gaz

Mes codes

Userform

Private fin_chrono As Long
Public EpreuveAdresse As String
Public EpreuveNom As Variant

Private Sub BTN_Annule_Click()
Unload Me
End Sub

Private Sub BTN_Copie_resultat_Click()

Dim Ligne As Long
Dim Point As Integer
Dim L As Integer

Point_obstacle = 0
Point_Refus = 0

Ligne = [B65536].End(xlUp).Row + 1
Range("AB" & Ligne) = Chrono.Caption      ' Chrono
Range("A" & Ligne) = Liste_cavalier            ' cavalier
Range("AW25") = Liste_cavalier
Range("B" & Ligne) = Cheval               ' Cheval
Range("C" & Ligne) = Ecurie               ' Ecurie

'=== Decompte des points=======

      '========== Points fautes obstacles
   If UserForm1.Obstacle_1 = True Then
    Range("D" & Ligne) = 4
        End If
   If UserForm1.Obstacle_2 = True Then
    Range("E" & Ligne) = 4
        End If
   If UserForm1.Obstacle_3 = True Then
    Range("F" & Ligne) = 4
         End If
   If UserForm1.Obstacle_4 = True Then
    Range("G" & Ligne) = 4
         End If
   If UserForm1.Obstacle_5 = True Then
    Range("H" & Ligne) = 4
         End If
    If UserForm1.Obstacle_6 = True Then
    Range("I" & Ligne) = 4
         End If
    If UserForm1.Obstacle_7 = True Then
    Range("J" & Ligne) = 4
        End If
    If UserForm1.Obstacle_8 = True Then
    Range("K" & Ligne) = 4
        End If
    If UserForm1.Obstacle_9 = True Then
    Range("L" & Ligne) = 4
        End If
    If UserForm1.Obstacle_10 = True Then
    Range("M" & Ligne) = 4
        End If
    If UserForm1.Obstacle_11 = True Then
    Range("N" & Ligne) = 4
        End If
    If UserForm1.Obstacle_12 = True Then
    Range("O" & Ligne) = 4
        End If

    '======== POINTS REFUS

     If UserForm1.refus_1 = True Then
     Range("P" & Ligne) = 4
        End If
     If UserForm1.refus_2 = True Then
     Range("Q" & Ligne) = 4
        End If
            '======= REFUS 3 100 point éliminé
            If UserForm1.refus_3 = True Then
            Range("R" & Ligne) = 100
            Range("AA" & Ligne) = "Eliminé(e)"
        End If

    '======== CHUTE Elimination
    If UserForm1.Chute_1 = True Then
    Range("S" & Ligne) = 100
    Range("AA" & Ligne) = "Eliminé(e)"
    End If
    '========== FAUTES Techniques
    If UserForm1.Faute_Tech_1 = True Then
    Range("T" & Ligne) = 4
        End If
   If UserForm1.Faute_Tech_2 = True Then
    Range("U" & Ligne) = 4
        End If
   If UserForm1.Faute_Tech_3 = True Then
    Range("V" & Ligne) = 4
         End If
   If UserForm1.Faute_Tech_4 = True Then
    Range("W" & Ligne) = 4
         End If
   If UserForm1.Faute_Tech_5 = True Then
    Range("X" & Ligne) = 4
         End If

        If UserForm1.Faute_Tech_Elimine = True Then
        Range("Y" & Ligne) = 100
        Range("AA" & Ligne) = "Eliminé(e)"
         End If

'======== TRIE en sortant============
'Dim L As Integer
L = Range("A65536").End(xlUp).Row
Range("A4:AB" & L).Select

 If Range("A4").Value = "" Then
 MsgBox ("Pas de Participants")
 Else
    Selection.Sort Key1:=Range("Z4"), Order1:=xlAscending, Key2:=Range("AB4"), Order2:=xlAscending
 If Range("A4") = Range("AW25") Then
      Call Son4
 End If
 End If

End Sub

Private Sub BTN_Depart_Click()
    CumulTimer = 0
    GoTimer = Timer
    'Précision de IntervalT à adapter selon possibilités d'affichage
    TimerOn IntervalT:=50                   'en millièmes de seconde

    BTN_Depart.Enabled = False
    BTN_Reprendre.Enabled = False
    BTN_Fin.Enabled = True
    BTN_Pause.Enabled = True
End Sub

Private Sub BTN_Pause_Click()
    TimerOff
    CumulTimer = CumulTimer + (Timer - GoTimer)

    BTN_Pause.Enabled = False
    BTN_Reprendre.Enabled = True
End Sub

Private Sub BTN_Reprendre_Click()
    GoTimer = Timer
    TimerOn IntervalT:=50                   'en millièmes de seconde

    BTN_Pause.Enabled = True
    BTN_Reprendre.Enabled = False
End Sub

Private Sub BTN_Fin_Click()
    TimerOff

    BTN_Depart.Enabled = True
    BTN_Pause.Enabled = False
    BTN_Reprendre.Enabled = False
    BTN_Fin.Enabled = False

    'MsgBox "Le chrono est de : " & Chrono.Caption & vbLf & vbLf & "Attention: cette valeur n'est pas numérique (= chaine de caractères) !"
End Sub

Private Sub CommandButton6_click()

End Sub

Private Sub Concurent_Click()

End Sub

Private Sub Label7_Click()

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    TimerOff
End Sub

'Private Sub BTN_Depart_Click() ' Depart du Chrono
'Dim DEPART As Double
'Dim Temps As Double
'BTN_Depart.Enabled = False

'fin_chrono = 0
'DEPART = [now()]
'Do While fin_chrono = 0
    'Temps = [now()] - DEPART
        'If CheckBox1 = False Then
        'Chrono.Caption = WorksheetFunction.Text(Temps, "hh:mm:ss.00")
        'Else
        'Chrono.Caption = WorksheetFunction.Text(Temps, "hh:mm:ss")
    'End If
'DoEvents
'Loop

'End Sub
'Private Sub BTN_Fin_Click() 'Arrete le Chrono
'FIN
'End Sub

'==== SI CHUTE Arrete le Chrono
Private Sub Chute_1_Click() 'Case chute clic arrete le chrono
FIN
End Sub
'==== SI FAUTE Elimine Arrete le Chrono
Private Sub Faute_Tech_Elimine_Click() 'Case Faute tech elimine clic arrete le chrono
FIN
End Sub
'==== SI 3 refus Arrete le Chrono
Private Sub refus_3_Click() 'Case Refu 3 clic arrete le chrono
FIN
End Sub

Function FIN()
TimerOff
    BTN_Depart.Enabled = True
    BTN_Pause.Enabled = False
    BTN_Reprendre.Enabled = False
    BTN_Fin.Enabled = False
End Function

Private Sub Liste_cavalier_Change()
Dim EpreuveColonneCheval As String
Dim EpreuveColonneClub As String
Dim EpreuveColonneNuméro As String
'Dim EpreuveNom As Variant

EpreuveNom = ActiveWorkbook.ActiveSheet.Name
EpreuveColonneCheval = EpreuveNom & "!AE" 'Affiche le nom du cheval
EpreuveColonneClub = EpreuveNom & "!AF"   'Affiche le non du club
EpreuveColonneNuméro = EpreuveNom & "!AG"   'Affiche le Numéro

If Liste_cavalier.ListIndex = -1 Then Exit Sub

Me.Cheval.Value = Range(EpreuveColonneCheval & Liste_cavalier.ListIndex + 2)
Me.Ecurie.Value = Range(EpreuveColonneClub & Liste_cavalier.ListIndex + 2)
Me.Numéro.Value = Range(EpreuveColonneNuméro & Liste_cavalier.ListIndex + 2)

End Sub

Private Sub userForm_Initialize()
Dim T_limite As Double
Dim T_depasse As Double
'Dim EpreuveAdresse As String
'Dim EpreuveNom As Variant

Me.Liste_cavalier.ColumnCount = 3 'affecte 3 colonnes à la liste
Me.Nom_Epeuve = ActiveWorkbook.ActiveSheet.Name 'Affiche le nom de l'epreuve dans le Formulaire

EpreuveNom = ActiveWorkbook.ActiveSheet.Name 'Range("A1").Value
EpreuveAdresse = EpreuveNom & "!AD2:AF9" 'position de la liste
'MsgBox (EpreuveAdresse)

'========= Alimentation de la liste

Me.Liste_cavalier.RowSource = EpreuveAdresse & Sheets(EpreuveNom).Cells(1, 1).End(xlDown).Row

Me.Liste_cavalier.ColumnWidths = "130;75;60" 'Dimention des colone dans la liste
Me.Liste_cavalier.ListIndex = 0              ' affiche les données de la ligne 1

T_depasse = Sheets("Paramétres").Range("B2").Value
Me.Temps_depasse.Caption = WorksheetFunction.Text(T_depasse, "mm:ss.00")

T_limite = Sheets("Paramétres").Range("C2").Value
Me.Temps_limite.Caption = WorksheetFunction.Text(T_limite, "mm:ss.00")

T_Départ = Sheets("Paramétres").Range("D2").Value
Me.Temps_avant_départ.Caption = WorksheetFunction.Text(T_Départ, "mm:ss.00")

With Me
        .StartUpPosition = 3
        .Width = Application.Width
        .Height = Application.Height
        .Left = 0
        .Top = 0
    End With

End Sub

Private Sub CommandButton10_Click()
Call Son3
End Sub

Private Sub CommandButton11_Click()
Call Son4
End Sub
Private Sub BTN_RAZ_Click()
    TimerOff
    Chrono.Caption = "00:00:00"
    Dim Ctrl As Control, TheNum As Byte
For Each Ctrl In Me.Controls
If TypeOf Ctrl Is MSForms.CheckBox Then
With Ctrl
.Value = False
End With
End If
Next Ctrl
End Sub

Module timer

Option Explicit

Private Declare Function SetTimer Lib "User32" (ByVal hWnd As Long, _
            ByVal nIDEvent As Long, ByVal uElapse As Long, _
            ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "User32" (ByVal hWnd As Long, _
            ByVal nIDEvent As Long) As Long

Dim TimerID As Long
Public GoTimer As Single, CumulTimer As Single

Sub TimerOff()
    'Timer désactivé
    KillTimer 0, TimerID
End Sub

Sub TimerOn(IntervalT As Long)
    'Timer actif
    TimerID = SetTimer(0, 0, IntervalT, AddressOf Chrono)
End Sub

Sub Chrono()
Dim T As String
Dim h As Single
    'MAJ de l'afficheur Chrono
    h = Round(CumulTimer + (Timer - GoTimer), 2)
    T = Format(TimeSerial(0, 0, h), "nn:ss")
    With UserForm1
        If Not .chk10em.Value Then  'Affichage centième CheckBox1
            T = T & "." & Format(Int((h - Int(h)) * 100), "00")
        End If
        .Chrono.Caption = T
    End With
End Sub

Voila j'ai essayer de vous expliquer au mieux mon besoin

Merci pour votre aide

Le 23/01/2013 à 09:07

Hello tout le monde,

Joins ton fichier si tu peux...

Le 24/01/2013 à 16:33

Bonjour,

Je ne souhaite pas envoyer tout mon fichier, car j'ai déja été victime de récupération d'un de mes fichiers qui, par la suite a été modifier et vendu

En ce qui me concerne ce n'est pas le cas, juste une utilisation dans mon club

J'èspere que vous pourrez m'aider avec les codes que je vous mets sur le forum

Merci pour votre aide

Cordialement

Le 24/01/2013 à 21:41

Hello,

Soit, je comprends.

En revanche je ne vais pas pouvoir continuer à vous aider.

Rechercher des sujets similaires à "compte rebours userform conditions"