Compte à rebours apparent

[mike13]

Bonjour à tout le monde,

J'utilise pour des stagiaires une feuille avec un temps imparti inclus dans une macro qui ferme automatiquement le fichier dès que le temps est fini.
Pour que le stagiaire ne soit pas surpris, j'aimerais ajouter un compte à rebours qui reste visible en permanence.
Je ne sais pas faire.
Pouvez-vous m'aider ?

Merci à tous par avance.

MIKE13

 

[PMO2]

Re : Compte à rebours apparent

Bonjour,

Une solution en utilisant la Barre d'état pour l'affichage du compte à rebours.
Copiez le code suivant dans un module standard en ayant, préalablement, adapté les
constantes (cernées par des #) à votre usage.

'### Constantes à adapter ###
Const DUREE As Long = 30                    'durée en secondes
Const PREFIXE As String = "Temps restant "  'préfixe qui s'inscrit dans la Barre d'état
'############################

Private Debut As Date
Private Fin As Date

Sub CompteRebours()
Dim Etat As Boolean
Etat = Application.DisplayStatusBar
If Not Etat Then Application.DisplayStatusBar = True
Debut = Time
Fin = Debut + DUREE / 86400
Application.StatusBar = PREFIXE & Format(Fin - Time, "hh:mm:ss")
Call Rebours
Application.StatusBar = False
Application.DisplayStatusBar = Etat
MsgBox "Terminé"

  '--- Insérez votre traitement STOP ---
  
End Sub

Sub Rebours(Optional dummy As Byte)
Dim Pause As Long
Dim Start As Date
Dim A$
On Error GoTo Erreur
Pause = 1
Start = Timer
Do While Timer < Start + Pause
  DoEvents
Loop
If Fin - Time <= 0 Then
  Error 65535
End If
A$ = Format(Fin - Time, "hh:mm:ss")
If Application.StatusBar <> PREFIXE & A$ Then
  Application.StatusBar = PREFIXE & A$
  If CLng(Format(A$, "hhmmss")) <= 10 Then Beep
End If
Call Rebours 'appel récursif
Exit Sub
'--- Pseudo traitement d'erreur ---
Erreur:
End Sub

Il n'y a plus qu'à lancer la procédure Sub CompteRebours.

Cordialement.

PMO
Patrick Morange

 

[BOISGONTIER]

Re : Compte à rebours apparent

Bonsoir,

http://boisgontierjacques.free.fr/fichiers/Evenementiel/OnTimeDecompte.xls

JB