Discussion :

[bbkenny]

Est ce que le Timer existe en VBA, comme sous Visual Basic.
En effet, je cherche à executer une fonction cycliquement.

Par avance merçi.

[zazaraignée]

Salut

Regarde dans l'aide du côté de la fonction Timer. Il y a un exemple.

[bbkenny]

La fonction Timer (qui renvoie le nombre de secondes écoulées depuis minuit) ne semble pas correspondre à ce que je cherche.

Je cherche l'équivalent de l'objet Timer en VB qui permet de déclencher un évennement à interval de temps régulié, mais en VBA, dans une feuille Excel.

[michelxld]

bonsoir

tu peux tester la méthode OnTime
ci dessous les exemples fournis dans l'aide en ligne Excel

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
exécuter my_Procedure dans 15 secondes.
Application.OnTime Now + TimeValue("00:00:15"), "my_Procedure"
 
exécuter my_Procedure à 17 heures.
Application.OnTime TimeValue("17:00:00"), "my_Procedure"
 
annuler le paramétrage de OnTime de l'exemple précédent.
Application.OnTime EarliestTime:=TimeValue("17:00:00"), _
    Procedure:="my_Procedure", Schedule:=False

bonne soiree
michel

[DarkVader]

Avec les Api

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Public Declare Function timeSetEvent Lib "winmm.dll" (ByVal uDelay As Long, ByVal uResolution As Long, ByVal lpFunction As Long, ByVal dwUser As Long, ByVal uFlags As Long) As Long
Public Declare Function timeKillEvent Lib "winmm.dll" (ByVal uID As Long) As Long

et une procédure en callback c'est plus propre.

[bbkenny]

Dabord, merçi pour vos reponses.

J'ai testé la solution de michelxld qui semble fonctionner pour ce que je veux faire.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
exécuter my_Procedure dans 15 secondes. 
Application.OnTime Now + TimeValue("00:00:15"), "my_Procedure" 
 
exécuter my_Procedure à 17 heures. 
Application.OnTime TimeValue("17:00:00"), "my_Procedure" 
 
annuler le paramétrage de OnTime de l'exemple précédent. 
Application.OnTime EarliestTime:=TimeValue("17:00:00"), _ 
    Procedure:="my_Procedure", Schedule:=False

Par contre, je ne vois pas bien comment utiliser la méthode à DarkVader.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Public Declare Function timeSetEvent Lib "winmm.dll" (ByVal uDelay As Long, ByVal uResolution As Long, ByVal lpFunction As Long, ByVal dwUser As Long, ByVal uFlags As Long) As Long 
Public Declare Function timeKillEvent Lib "winmm.dll" (ByVal uID As Long) As Long

Je n'ai rien trouvé dans l'aide de VBA ! ! !

[DarkVader]

dans un module

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Public Const TIME_PERIODIC = 1
Public Const TIME_CALLBACK_FUNCTION = &H0   
 
Public Declare Function timeSetEvent Lib "winmm.dll" (ByVal uDelay As Long, ByVal uResolution As Long, ByVal lpFunction As Long, ByVal dwUser As Long, ByVal uFlags As Long) As Long
Public Declare Function timeKillEvent Lib "winmm.dll" (ByVal uID As Long) As Long
 
 
Sub TimerProc(ByVal uID As Long, ByVal uMsg As Long, ByVal dwUser As Long, ByVal dw1 As Long, ByVal dw2 As Long)
'    MaProcédure : la procédure TimerProc sera appelée suivant la fréquence prédéfinie
 
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Public hTimer as long
sub TimerStart()
    dim frequenceTime as long
    frequenceTime =10
 
    'Initialisation du timer
    hTimer = timeSetEvent(frequenceTime, 0, AddressOf TimerProc, 0, TIME_PERIODIC Or TIME_CALLBACK_FUNCTION)
end sub
sub TimerStop()
    'Arrêt du timer
    timeKillEvent hTimer
endsub

TIME_ONESHOT (= 0) appelé à la place de TIME_PERIODIC permet de limiter à un seul appel de la procédure timerproc

[bbkenny]

Désolé, même avec tous ces détails, je ne m'en sort pas.
Dès que j'execute TimerStart() je bloque mon PC (UC à 100%). J'ai mis la variable frequenceTime à 1000 (frequence : toutes les secondes). Dans TimerProc, je me contente d'écrire l'heure dans une cellule Excel pour tester.

[zazaraignée]

Salut

N'empêche que la fonction Timer...
J'ai pris l'exemple dans l'aide et je l'ai rendu récursif...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub CestLaPause()
    Dim PauseTime, Start, Finish, TotalTime
    If (MsgBox("Cliquez sur Oui pour effectuer une " & _
            "pause de 5 secondes", 4)) = vbYes Then
        PauseTime = 5   ' Définit la durée.
        Start = Timer   ' Définit l'heure de début.
        Do While Timer < Start + PauseTime
            DoEvents    ' Donne le contrôle à d'autres
                        ' processus.
        Loop
        Finish = Timer  ' Définit l'heure de fin.
        TotalTime = Finish - Start  ' Calcule la durée
                                                ' totale.
 
    MsgBox "Pause de " & TotalTime & " seconde(s)"
    Else
        End
    End If
    CestLaPause
End Sub

Bon. C'est toi qui voit!

[DarkVader]

j'ai testé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    If Worksheets("Feuil1").Range("A1") = "" Then Worksheets("Feuil1").Range("A1") = Format(Now(), "dd/mm/yy hh:mm:ss")

dans TimerProc et ça fonctionne très bien

[bbkenny]

Je suis vraiment désolé DarkVader, je ne vois pas le problème. Dans un module j'ai :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Public Const TIME_PERIODIC = 1
Public Const TIME_CALLBACK_FUNCTION = &H0
 
Public Declare Function timeSetEvent Lib "winmm.dll" ( _
            ByVal uDelay As Long, _
            ByVal uResolution As Long, _
            ByVal lpFunction As Long, _
            ByVal dwUser As Long, _
            ByVal uFlags As Long) As Long
 
Public Declare Function timeKillEvent Lib "winmm.dll" ( _
            ByVal uID As Long) As Long
 
Sub TimerProc(ByVal uID As Long, _
                ByVal uMsg As Long, _
                ByVal dwUser As Long, _
                ByVal dw1 As Long, _
                ByVal dw2 As Long)
 
       Worksheets("Feuil1").Range("A1") = Format(Now(), "dd/mm/yy hh:mm:ss")
 
End Sub

Et dans ma feuille Excel, j'ai deux boutons et :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Public hTimer As Long
 
Private Sub CommandButton1_Click()
    Dim frequenceTime As Long
    frequenceTime = 1000
 
    'Initialisation du timer
    hTimer = timeSetEvent( _
                frequenceTime, _
                0, _
                AddressOf TimerProc, _
                0, _
                TIME_PERIODIC Or TIME_CALLBACK_FUNCTION)
 
End Sub
 
Private Sub CommandButton2_Click()
    'Arrêt du timer
    timeKillEvent hTimer
End Sub

Cela resemble fortement à ce que tu m'as fourni, puisque c'est du copié collé . . .
J'affiche bien l'heure, et puis PC à 100% d'UC et bloqué ou fortement sacadé ! ! !

*************************

Ok pour la méthode à zazaraignée, celà fonctionne. Quand on est dans la boucle Do While Loop le PC et à 100% d'UC mais ne bloque rien. Je pense que cette méthode ne va pas me convenir car pour ce que je veux faire, je serais en permanance à 100%. Même si celà ne bloque pas les autres procèssus je pense que celà risque d'avoir pour consequence une chauffe du processeur (je pense non : : : ) ! ! !
Mais je te remerçie pour l'intérêt que tu porte à mon problème.

[bhaal76]

j'ai testé aussi, en rajoutant des points d'arrêt sur chaque procédure, et chose curieuse, dès qu'il arrive sur la ligne "Sub TimerProc", plus moyen de débugger ... et fin de tache sur excel pour fermé le documents !

[michelxld]

bonsoir

ci joint un exemple complet avec OnTime , testé avec Excel2002
lorsque la macro "LancerLaProcedure" est démarrée , la cellule B1 est incrémentée d'une unité toutes les 2 secondes .
il faut saisir la valeur 1 dans la cellule A1 pour terminer la procedure

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
'la macro incrémente la cellule B1 d'une unité toutes les 2 secondes
' !! saisir la valeur 1 dans la cellule A1 pour terminer la procedure !!
'***************************************
Sub LancerLaProcedure()
Temporisation
End Sub
'***************************************
 
''**************************************
Sub Temporisation()
'timer toutes les 2 secondes
Application.OnTime Now + TimeValue("00:00:02"), "maMacro"
End Sub
 
 
Sub maMacro()
Range("B1") = Range("B1") + 1 'incementation de la cellule B1
 
If Range("A1") = 1 Then ' terminer la procedure si la cellule A1=1
Finir
Exit Sub
End If
 
Temporisation
 
End Sub
 
Sub Finir()
On Error Resume Next
Application.OnTime Now + TimeValue("00:00:01"), "maMacro", , Schedule:=False
End Sub
 
'*****************************************

bonne soirée
michel

[bbkenny]

Je l'avais signalé plus haut que la méthode à michelxld fonctionne.

[DarkVader]

Je dois disposer d'une version d'Excel avec slip blindé -
est-ce que cela tient au fait qu'il s'agisse de la version XP 2002 !

Certains codes posent problèmes dans la procédure de callback
car elle ne supporte aucune erreur de codage ni apparemment les interactions avec l'utilisateur !
Ainsi le code de test suivant fonctionne avec un label mais pas un textbox actif !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
'Dans un module
 
Public hTimer As Long
 
Public Const TIME_PERIODIC = &H1
Public Const TIME_CALLBACK_FUNCTION = &H0
 
Public Declare Function timeSetEvent Lib "winmm.dll" (ByVal uDelay As Long, ByVal uResolution As Long, ByVal lpFunction As Long, ByVal dwUser As Long, ByVal uFlags As Long) As Long
Public Declare Function timeKillEvent Lib "winmm.dll" (ByVal uID As Long) As Long
 
Sub TimerProc(ByVal uID As Long, ByVal uMsg As Long, ByVal dwUser As Long, ByVal dw1 As Long, ByVal dw2 As Long)
'    MaProcédure : la procédure TimerProc sera appelée suivant la fréquence prédéfinie
'   ATTENTION : Aucune erreur n'est supportée à ce niveau - Eviter les points d'arrêts
    Form1.Label1.Caption = Format(Now(), "dd/mm/yy hh:mm:ss")
        ' ou procédure de rappel
End Sub
 
 
Sub test()
    Form1.Show
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
' Dans un Userform nommé Form1 et contenant un label nommé Label1
 
Sub TimerStart()
    Dim frequenceTime As Long
    frequenceTime = 1000
 
    'Initialisation du timer
    hTimer = timeSetEvent(frequenceTime, 0, AddressOf TimerProc, 0, TIME_PERIODIC Or TIME_CALLBACK_FUNCTION)
End Sub
Sub TimerStop()
    'Arrêt du timer
    timeKillEvent hTimer
End Sub
 
Private Sub UserForm_Activate()
    Form1.Label1.Caption = Format(Now(), "dd/mm/yy hh:mm:ss")
    TimerStart
End Sub
Private Sub UserForm_Terminate()
    TimerStop
End Sub

le test est lancé depuis la fenêtre d'exécution en appelant la procédure test.

Si ce code non surchargé ne fonctionne pas chez vous,
alors il y a un problème lié à la version d'Excel.

[bhaal76]

il doit effectivement y avoir un problème de version de dll ou je ne sais quoi, car même avec la verion d'office XP, et avec ton code (j'ai rien changé du tout, copier, coller, un module, un userform "form1" et un label "label1"), en lançant "test", en mode pas a pas, j'arrive jusqu'au

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    TimerStart

qui appelle au bout d'une seconde

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Sub TimerProc(ByVal uID As Long, ByVal uMsg As Long, ByVal dwUser As Long, ByVal dw1 As Long, ByVal dw2 As Long)

et la, plus moyen de debugguer, je reste sur "Sub TimerProc..."

"F8" ne fonctionne pas et je ne peux même pas déplacer la flèche jaune sur "end sub" ou autre !!!

la version de ma dll vinmm.dll est "5.1.2600.1106"

[DarkVader]

La version de winmm.dll : 5.1.2600.1106 (xpsp1.020828-1920)

Version des dépendances de winmm :
advapi32.dll 5.1.2600.1106 (xpsp1.020828-1920)
gdi32 5.1.2600.1346 (xpsp2.040109-1800)
kernel32 5.1.2600.1106 (xpsp1.020828-1920)
ntdll 5.1.2600.1217 (xpsp2.030429-2131)
RPCRT4 5.1.2600.1254 (xpsp2.030801-1834)
USER32 5.1.2600.1255 (xpsp2.030804-1745)

[bhaal76]

winmm.dll : 5.1.2600.1106 (xpsp1.020828-1920) idem
dépendance :
advapi32.dll : 5.1.2600.1106 (xpsp1.020828-1920) idem
gdi32 : 5.1.2600.1346 (xpsp2.040109-1800) idem
kernel32 : 5.1.2600.1106 (xpsp1.020828-1920) idem
ntdll32 : j'ai pas (ntdll 5.1.2600.1217 (xpsp2.030429-2131)
NPCRT4 : j'ai pas
USER32 : 5.1.2600.1255 (xpsp2.030804-1745) idem

je vais jeter un oeil sur google ...

[DarkVader]

désolé ce n'est pas ntdll32 mais ntdll ni npcrt4 mais rpcrt4
au cas où, j'ai déposé une copie de rpcrt4 pour me faire pardonner.

[bhaal76]

c'est pas grave ... donc :
ntdll : 5.1.2600.1217 (xpsp2.030429-2131) idem
RPCRT4 : 5.1.2600.1361 (xpsp2.040109-1800) ah, différent
je vais voir si je peux tester avec la tienne ...