Timer pour VBA et ouverture de fenêtres Excel

Question

Bonjour, J'ai récupéré le timer suivant pour VBA. Il fonctionne très bien à une exeption près: il est difficile d'ouvrir une autre fauille Excel lorsque celui ci est lancé. Quelle est l'astuce pour remédier à ce problème ? Merci d'avance pour votre aide. Rico Ci dessous la décomposition de ce timer. Dans une feuille: Option Explicit 'Déclaration du 'Timer' Private WithEvents Timer1 As VBAProject.Timer Private Sub CommandButton1_Click() CommandButton1.Enabled = False CommandButton2.Enabled = True CommandButton3.Enabled = True Cells(1, 2).Select 'Création de Timer1 Set Timer1 = New VBAProject.Timer 'Activer Timer1 Timer1.Enabled = True End Sub Private Sub CommandButton2_Click() CommandButton1.Enabled = True CommandButton2.Enabled = False CommandButton3.Enabled = False Cells(1, 2).Select Timer1.Enabled = False 'Fermeture de Timer1 Set Timer1 = Nothing End Sub Private Sub CommandButton3_Click() Cells(1, 2).Select Timer1.interval = Cells(1, 2).Value End Sub 'Evènement du Timer Private Sub Timer1_Timer() Cells(10, 1).Value = "Il est " & Time & " et " & (Timer - Int(Timer)) * 1000 & "ms" End Sub Dans un module de classe qui s'apelle "Timer" Option Explicit Private localInterval As Long Private localEnabled As Boolean Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private TimeOptions As FILETIME ' Durée transmise à la fonction SetWaitableTimer Private Declare Function CreateWaitableTimer Lib "kernel32" Alias "CreateWaitableTimerA" (ByVal lpSemaphoreAttributes As Long, ByVal bManualReset As Long, ByVal lpName As String) As Long Private Declare Function SetWaitableTimer Lib "kernel32" (ByVal hTimer As Long, lpDueTime As FILETIME, ByVal lPeriod As Long, ByVal pfnCompletionRoutine As Long, ByVal lpArgToCompletionRoutine As Long, ByVal fResume As Long) As Long Private Declare Function CancelWaitableTimer& Lib "kernel32" (ByVal hTimer As Long) Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function MsgWaitForMultipleObjects Lib "user32" (ByVal nCount As Long, pHandles As Long, ByVal fWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long Private TimerhWait As Long Private CancelTimer As Boolean Private TimerRunning As Boolean Public Event Timer() '---------------------------------------------------------------------------------------------------------------------- 'Routine de temporisation... ' : milisecondes ' : <= 0 Annuler l'attente ' : > 0 Démarrer la boucle d'attente Public Property Let interval(vdata As Long) 'Si le Timer est activé If localEnabled Then 'Reset le drapeau d'annulation CancelTimer = False 'Si la durée est inférieur ou égale à zéro If vdata <= 0 Then 'Durée de la temporisation : ms TimeOptions.dwLowDateTime = -1 'Mettre à jour la variable locale localInterval = vdata 'Sinon Else 'Si le timer tourne déjà If TimerRunning Then 'Annule le décompte en cours CancelWaitableTimer TimerhWait 'Convertir la nouvelle durée TimeOptions.dwLowDateTime = CLng(vdata * -10000) 'Programmer le déclenchement de l'évènement 'TimerhWait' dans 'TimeOptions' ms SetWaitableTimer TimerhWait, TimeOptions, 0, 0, 0, 0 'Mettre à jour la variable locale localInterval = vdata 'Sinon Else 'Définir localement le timer comme tournant TimerRunning = True 'Mettre à jour la variable locale localInterval = vdata 'Convertir la nouvelle durée TimeOptions.dwLowDateTime = CLng(vdata * -10000) 'Boucle infinie (jusqu'à annulation) Do Until TimeOptions.dwLowDateTime = -1 'Programmer le déclenchement du prochain évènement 'TimerhWait' dans 'Timeoptions' ms SetWaitableTimer TimerhWait, TimeOptions, 0, 0, 0, 0 'Boucle d'attente sans stress (Attendre le déclenchement de l'évènement 'TimerhWait') Do While MsgWaitForMultipleObjects(1, TimerhWait, False, &HFFFF, &HFF) > 0 DoEvents 'If CancelTimer Then Exit Do Loop 'Si annulation, sortir de la boucle infinie If TimeOptions.dwLowDateTime = -1 Then Exit Do 'Déclenchement de l'évènement 'Timer' RaiseEvent Timer Loop 'Définir localement le timer à l'arrêt TimerRunning = False End If End If 'Sinon Else 'Mettre à jour la variable locale localInterval = vdata End If End Property Public Property Get interval() As Long interval = localInterval End Property Public Property Let Enabled(vdata As Boolean) 'Si changement If vdata <> localEnabled Then 'Si activation If vdata Then 'Mettre à jour la variable locale localEnabled = vdata 'Si l'intervalle est supérieur à zéro If localInterval > 0 Then 'Mise en route du timer Me.interval = localInterval End If 'Sinon Else 'Annulation TimeOptions.dwLowDateTime = -1 'Mettre à jour la variable locale localEnabled = vdata End If End If End Property Public Property Get Enabled() As Boolean Enabled = localEnabled End Property Private Sub Class_Initialize() 'Création de l'horloge TimerhWait = CreateWaitableTimer(0, True, "Timer6RatsMorts") 'Initialisation de la durée TimeOptions.dwHighDateTime = -1 TimeOptions.dwLowDateTime = -1 End Sub Private Sub Class_Terminate() TimeOptions.dwHighDateTime = -1 TimeOptions.dwLowDateTime = -1 CloseHandle TimerhWait End Sub

cs_casy · Answer

Dans le commandbutton1 tu crée et lance le timer mais tu ne lui precise nulle part la valeur de l'intervale à utiliser. Hors si j'ai bien compris le code de la classe, cette valeur est par défaut égale à 1ms.

Ce qui veut dire que ta routine Timer1_Timer sera executer toutes les 1ms, ce qui laisse effectivement peu de temps pour faire autre chose

---- Sevyc64  (alias Casy) ----<hr size="2" width="100%" /># LE PARTAGE EST NOTRE FORCE #

Rico 95 · Answer

L'interval du timer se rentre dans la feuille de calcul par une valeur en ms à rentrer dans Cells (1,2).

On peut donc mettre des intervals de quelques secondes, par exemple 4000 (= 4 secondes) mais même avec ces durées, l'ouverture d'une autre feuille Excel est difficile. Le timer n'empêche pas de faire autre chose: on peux ouvrir d'autres applications, modifier les feuilles Excel, ...

C'est seulement l'ouverture d'un autre classeur Excel qui devient difficile.
Comment corriger ce problème ?

Rico

Timer pour VBA et ouverture de fenêtres Excel

2 réponses

Votre réponse

Discussions similaires