Compte à rebours qui n'en fait qu'à sa tête

[leop93]

Bonjour

J'ai modifié un compte à rebours pour sauvegarder et fermer automatiquement mon classeur au bout de 5 minutes si l'utilisateur n'annule pas le décompte avant la fin.

Tout fonctionne parfaitement au début, mais au bout de la troisième apparition (quoi que ça me paraît plus aléatoire que ciblé) du compte à rebours, il commence à bugger, à n'en faire qu'à sa tête. il se relance tout seul de nombreuses fois sans respecter les délais programmés...

J'ai essayé de modifier mon code, mais soit l'erreur continue d'avoir lieu, soit le compte à rebours ne marche plus...

Je vous ai joint mon code en PJ (UserForm1 pour la fenêtre et son code, Module2 pour le code du compte à rebours et ThisWorkbook pour la fonction SaveAndQuit et l'appel/initialisation du compte à rebours).

Bonne journée

Leop93

 

[MJ13]

Re : Compte à rebours qui n'en fait qu'à sa tête

Bonjour Leop

ces problèmes ne sont pas simples et j'ai beaucoup de mal a modifié un code complexe comme le tiens, mais comme ce sujet m'intéresse.

Donc, voici un exemple assez basique. A toi de voir si c'est adaptable 😕.

 

[leop93]

Re : Compte à rebours qui n'en fait qu'à sa tête

Bonjour MJ

Je n'ai pas trop compris ton exemple, peut être que mon "cerveau" est endolori par les 8H quotidienne depuis 2 semaines que je passe sur ce code VBA. 😱

Leop93

 

[leop93]

Re : Compte à rebours qui n'en fait qu'à sa tête

Bonjour

J'ai trouvé comment solutionner le problème.

J'ai retiré cette partie de code de mon Module:

        Application.OnTime _
        EarliestTime:=Now + TimeValue("00:01:00"), _
        Procedure:="ExecutionTimer", _
        Schedule:=True

Et je l'ai plassé dans mon bouton annuler, de la sorte:

Private Sub CommandButton1_Click()
        Application.OnTime _
        EarliestTime:=Now + TimeValue("00:01:00"), _
        Procedure:="ExecutionTimer", _
        Schedule:=True
Unload Me
End
End Sub

Et depuis plus aucun soucis. J'ai aussi remplacé le:

ActiveWorkbook.Close

par:

ThisWorkbook.Close

Car si Excel était ouvert sur un autre classeur, c'était celui-ci qui était fermé et non celui qui contenait le code à éxécuter.

En pièce jointe, le compte à rebours fonctionnel:

- lancement automatique après 1 minute
- demande à l'utilisateur si fermeture ou non
- si pas d'action sauvegarde et fermeture
- si annulation, lancement automatique 1 minute plus tard

 

[MJ13]

Re : Compte à rebours qui n'en fait qu'à sa tête

Bonjour Leop

Merci, c'est cool de donner ta solution 🙂.

 

[leop93]

Re : Compte à rebours qui n'en fait qu'à sa tête

Bonjour MJ

De rien, c'est le but du forum de partager non ? 🙂

Leop93

 

[leop93]

Re : Compte à rebours qui n'en fait qu'à sa tête

Bonjour

Je me suis rendu compte qu'il arrivait encore parfois qu'un petit soucis se glisse dans le lancement de mon compte à rebours.

Mais cette fois-ci, je pense que ça sera la bonne version. J'avais bêtement oublié d'appeler la fonction qui arrête le Compte à Rebours sur mon bouton annuler. Ce qui donne:

Private Sub CommandButton1_Click()
Call ArretTimer
        Application.OnTime _
        EarliestTime:=Now + TimeValue("00:01:00"), _
        Procedure:="ExecutionTimer", _
        Schedule:=True
Unload Me
End
End Sub

Donc voici le code au grand complet (en pièce jointe).

Bonne journée

Leop93

EDIT: et si ça tente quelqu'un, voici le code pour supprimer la croix en haut à droite (V5 en PJ):

Option Explicit
Private Declare Function GetWindowLongA Lib "User32" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLongA Lib "User32" _
(ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Private Declare Function FindWindowA Lib "User32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Sub UserForm_Initialize()
       Dim hWnd As Long
       Dim Feuille As String
       hWnd = FindWindowA("Thunder" & IIf(Application.Version Like "8*", _
       "X", "D") & "Frame", Me.Caption)
       SetWindowLongA hWnd, -16, GetWindowLongA(hWnd, -16) And &HFFF7FFFF
End Sub