VB6 - A very precise timer using Multithreading

This is a perfect example on how to use Multithreading in VB6

In the zip attached there are several projects, one of them is a Timer thread with 1 millisecond precision (at least).

Here is an explanation on what each project does:
QPTimerThread - Is the main Timer Thread
QPTimerTestSingleThread - Is a simple example on how to use the timer by showing an Analog clock with a line for Milliseconds also
QPTimerControl - Is a user control that encapsulates the Timer Thread so that you can create multiple timers at run time using control arrays.
QPTimerTestMultiThread - Is an example on how to use the control, the application will load as many timers as it can fit on the screen horizontally, and displays the events as changes in color in pictureboxes.

If you want to test with more than one thread compile the QPTimerThread project, and make sure that all the projects are referencing the QPTimer.exe

The Timer Thread will accept an Interval of 0.0001 Milliseconds increments (because it's using Currency variable type), but the actual precision varies between 0.1 ms to 1 ms. Also, the smallest Interval accepted by the Timer Thread is 0.5 milliseconds. I did that because it is an approximate average of it's precision, and also because at 0.5 milliseconds it means that it will fire 2000 times per second, and that is quite a lot for a VB application.

Each Timer Thread from the moment it starts it goes in an Infinite loop, and there are 2 ways to stop it. First is through the TimerEvent() by passing False to the ContinueTimer parameter, this means that the application using the timer has to keep passing "True" to the timer to "keep it alive". The ContinueTimer is fine to use if your intervals are small, but if you use high intervals, you won't be able to stop the timer this way, that is why I've added a second option to stop the timer. And that is to send a Windows message to the timer thread telling it to exit the infinite loop, and that is done by simply running this line of code:

Code:

---

PostMessage mTimerWindow_hWnd, WM_USER + 1, 123456789, 987654321

---

I picked the 123456789 and 987654321 values to pass through the parameters to make sure that no other application will stop the timer unintentionally.

The precision of the timer comes from QueryPerformanceCounter API, and it's using the Sleep API to pause the thread for ~1 ms at the time so that it does not take a lot of resources (CPU) from the computer.

The TimerEvent() returns 2 parameters that might be of interest to you:
PrevEventDuration - is the duration of how much time was spent in the previous call to TimerEvent, in other words, how much time your code took to run in the previous event.
RunningInterval - if your code in the event runs longer than the Interval you set it to run, the RunningInterval will accumulate the time it is behind, and when your code runs faster than the Interval, the RunningInterval will get shorter up to 0 (zero) meaning it is not behind.

When you call the "StartTimer" function you pass the Mode to run in.
Mode1 means that if the timer runs behind, it will recover when it has the chance.
Mode2 means that if the timer runs behind, and it is more than TimeEventDrop value, then it will drop the event and seek to next event without calling the TimerEvent()
for example, if you call it like this "MyTimer.StartTimer 100, Mode2, , 50" and your code in the TimerEvent() takes 151 ms, then next event will be after 200 ms after the previous TimerEvent() call.
Mode3 is the same as the regular VB6 timer, except it is more precise. The interval is counted from the moment the TimerEvent() ends to the time it starts again. So if the interval is 100 ms, and your code runs for 20 ms, then the next TimerEvent() call is after 120 ms.

There are quite a lot more things that have to be explained, but the post will be too long, and I don't want to bore anyone... If you want to further understand how it works, please look at the code first, then ask questions if you have any.

If you have any questions or if you have any problem with any of the code, please post here.

Also... if you are a complete noob to VB and Multithreading, please post in the General VB forum, the code in this post is for moderate skill level programmers and up...

Screen shots:

QPTimerTestSingleThread - Single Thread app:
Attachment 62659

QPTimerTestMultiThread - Multi Thread app:
Attachment 62660

Can Some One Please Send Me A Working Copy Of The Timer? My Email Is [email protected]

OK... what do you mean by a "Working Copy" ?

You cannot get it to work ?

And we don't send stuff through e-mail, everything get's posted on the forums...

And you should remove your e-mail from the post if you don't want to get a lot of spam from the bots

Quote:

---

Originally Posted by Eranga Pilimatalawwe

Can Some One Please Send Me A Working Copy Of The Timer? My Email Is [email protected]

---

Was the link to the zip file too complicated for you??

I think he is expecting a reply through e-mail, but that will never happen from me....

Hi CVMichael and hi to all.

Sorry for English.

I am very interested to your code, because I have need to implement
a not Blocking Timer in my application.

My application use a timer for display countdown duration of video file
in a label and it fired every 40ms for counting frame.
My problem is that the Timer stop to count frame when other activity
are performed(e.g. switching file,load playlist…).

Can I use your code for this?
How I can implement a timer class with event and running in separate thread?
Can you show me some example?

I’m not expert with MultiThread application.

Thanks for your time
Best Regards
Nanni

The timer is in it's own thread, but your application (the code and interface/form) is only one thread.

Because your application is only in one thread, and your code is processing, the application interface (the form) will get "stuck" and it wont refresh the form until the code is done, you probably saw this many times...

Also, what this means is that if your application is busy doing something, and the timer fires, your application will not be able to process the timer event until it's done doing whatever it was doing, and there is nothing you can do about that (without changing the code), because events don't interrupt the code.

There are 2 things you can do that will let the timer fire:

1) Use DoEvents in every sub/function that does a lot of processing, inside loops especially... but this will slow down the functions. So you have to be carefull where you put the DoEvents, because if DoEvents is called too often then your functions will be really slow, and if it's not called enough times, then the timer/interface will still get stuck once in a while.

2) Put the code that takes a lot of processing (like loading the files, load playlist, etc.) in it's own thread.
That way, the loading file code will not interfere with the form/interface thread, and it will not interfere with the other threads like the timer.

So in other words, to be more specific about your question:
There is nothing you can do to make the timer fire right away if the code in your application/interface does not allow it to fire...

You have to change your existing code to allow the timer to fire.

Here is visual representation of what I mean:
http://www.vbforums.com/attachment.p...1&d=1210252033
Right now, you have the "Load file" and "Load playlist" in the same thread as the interface, what you have to do is take all that code out, and put it in it's own thread so that the interface can do everything related to the interface only...

Hi Michael
thanks for your reply.

Your explanations have been very useful :)

The only problem is that I don't know how to start.
How implement MultiThread in Vb?
Do you have some suggestion?

Thanks for your time
Best Regards
Nanni

Take a look at the attached projects

I made a sample thread for you, and I made it as simple as possible, you can't do it more simple than that....

Make sure you run the thread first (or compile it), and make sure that the ThreadTest project still has the propper reference, if not, just add the reference to the ThreadTemplate

how do i add the reference to the ThreadTemplate?

There are 2 ways...

You compile the thread, then open your project and go to "Project" menu, and click on "References", in the list, you should see "ThreadTemplate", and if you don't, click on browse, and find the thread exe, and select it.

Another way, is to just run the thread, then in another VB instance, open your project, and go to "project" menu, then click on "References", and you should see it in the list.

Thanks CVMichael ...:wave:

Thanks for putting this together CVMichael!

I wish I would have discovered this back in 2010!

Anyway, I've implemented this method, and have it mostly working.
I find that after I exit the test program, the QPTimer.exe is still loaded and running.
I launch TaskManager, and there it is under processes.

How do I shut it down when the calling program ends?

Thanks again!

I placed the following line in the Form_Unload event of the main screen in my program.

Code:

---

Shell ("cmd.exe /c TASKKILL /IM QPTimer.exe /F")

---

It does the job, but I was thinking there must be a way for the method described above to take care of the cleanup.

The thread is made with an ActiveX. ActiveX controls are like a service, they load when you start the application, and they don't un-load. But it's not running if you closed your application! the application creates an instance of the ActiveX, and this instance (and all other instances of the thread) executes under the main process, and return events to the application. So if you close your application, that instance (sub-process / thread) of the ActiveX also closes. The main process is still there waiting for an application (any application) to create an instance of it...

If that is still not clear, here is a quick Google find with a nice diagram:
https://msdn.microsoft.com/en-us/lib...=vs.60%29.aspx

So what you see in task manager is the main process, not the smaller processes (threads) that execute inside it...

Quote:

---

Originally Posted by Ken Whiteman

I placed the following line in the Form_Unload event of the main screen in my program.

Code:

---

Shell ("cmd.exe /c TASKKILL /IM QPTimer.exe /F")

---

It does the job, but I was thinking there must be a way for the method described above to take care of the cleanup.

---

In this particular case, this is OK to do. But in real situations, when you have multiple applications using the ActiveX, then you will be killing the processes (threads) of other applications that might be using it. So if you have more than one application using this ActiveX, the other applications will stop working (error-ing) the first time you close any of the applications.

Thanks CVMichael,

I reviewed the link and, I did understand what was going on, so it was a nice review!

As far as the Shell command goes- This entire task is application specific, and only 1 instance is allowed to run at a time.

Thanks again for responding, and thanks for creating this post!

Ken-

I apologize for reviving this project from many years ago, but it performs the function I was looking for for my application very well. I am using CVMichael's timer profitably in one of my applications, however when I install my program (also including the "QPTimer.exe" file) on another computer, the following message appears upon execution: "Error 429. Activex component can 't create object". I tried indirect instantiation with "CreateObject" but the error message when running WithEvents is "user-defined type undefined". How can I do?

Quote:

---

Originally Posted by fabel358

(also including the "QPTimer.exe" file)

---

I didn't download the project but if this EXE file you are referring to is indeed an ActiveX EXE then you need to register it before you can create objects from it with "CreateObject". Just run it once as administrator and it should register itself.

Quote:

---

Originally Posted by VanGoghGaming

I didn't download the project but if this EXE file you are referring to is indeed an ActiveX EXE then you need to register it before you can create objects from it with "CreateObject". Just run it once as administrator and it should register itself.

---

I had already done it. The error message is the following: "The module "QPTimer.exe" was loaded, but the DllRegisterServer entry point was not found.
Make sure "qptimer.exe" is a valid OCX or DLL file, then try again"

Quote:

---

Originally Posted by fabel358

Make sure "qptimer.exe" is a valid OCX or DLL file, then try again"

---

Well, obviously it's none of those, it's an EXE file, LoL! How are you trying to load it? An ActiveX EXE will register itself but only when you run it as administrator. You can do that from code as well if you run it with "ShellExecute" using the "runas" verb but you will get an UAC prompt.

You can use command line switches as well:

Code:

---

ActiveX.EXE /regserver
ActiveX.EXE /unregserver

---

Once it's registered you should be able to just create objects from it using either the "As New ClassName" or "CreateObject("ProjectName.ClassName") syntaxes.

I followed CVMichael's instructions: created the "EXE" file, it must be pointed to, by "references". The problem is that this blocks the address EXACTLY as it is on your system, so you can't install it on other computers.
Trying to register QPTimer.exe with CMD as administrator with "QPTimer.exe /regserver", reports nothing; however when I try to create the object (DIM tmrTime as object: Set tmrTime = CreateObject("QPTimer.exe") the error message is always 429 - ActiveX component cannot create object.

It seems I succeeded by compiling QPTimer as a "DLL", then registering the library with "REGSVR32" and putting a "DOEVENTS" inside the "Timer_TimerEvent" routine in the main program.

With further testing I saw that it works with CVMichael's example but it doesn't work in my application since it never gives up priority and the timer stays in a loop. Instead, with the compilation as "DLL ACTIVEX" everything works but the addressing problem remains connected to your system and cannot be installed on other computers.

Look at this code.

It seems I succeeded. The information had even been given by CVMichael; Unfortunately, some steps and details had been skipped which did not make the solution clear. During installation with INNOSETUP you must specify the following line in the "RUN" section which will register QPTimer.exe in the new system:
Filename: "{app}\QPTimer.exe"; Parameters: " /regserver"
Launching the application, everything works as it should!

I can't believe it's been 16 years since I did this :) and I can't believe it's still used, wow!

Quote:

---

Originally Posted by CVMichael

I can't believe it's been 16 years since I did this :) and I can't believe it's still used, wow!

---

It's the only timer project I've found that always executes the event (in Mode1) unlike VB6 timers. The difficulty is that, having never test "Exe ActiveX" components, I didn't understand how to activate them.

It always executes the event because the ActiveX EXE is running in a different thread, but if your application is busy doing something else at the time then it won't receive the timer event until it finishes whatever it was doing.

Also the title ("very precise timer") is somewhat deceiving because even though the timer uses the QueryPerformance functions, all precision goes down the drain by calling "Sleep 1" in a loop. In this regard it's not any more precise than a regular VB6 Timer. The precision of "Sleep 1" is about 16ms on average.

If you need a true 1 millisecond precision than you should use the multimedia timer as described by the timeSetEvent function.

Quote:

---

Originally Posted by VanGoghGaming

It always executes the event because the ActiveX EXE is running in a different thread, but if your application is busy doing something else at the time then it won't receive the timer event until it finishes whatever it was doing.

Also the title ("very precise timer") is somewhat deceiving because even though the timer uses the QueryPerformance functions, all precision goes down the drain by calling "Sleep 1" in a loop. In this regard it's not any more precise than a regular VB6 Timer. The precision of "Sleep 1" is about 16ms on average.

If you need a true 1 millisecond precision than you should use the multimedia timer as described by the timeSetEvent function.

---

I'm not interested in millisecond precision, what CVMichael programmed would be fine for me.
Unfortunately I encountered another problem: when the application is compiled, postmessage does not close the QPTimer.exe timer. In the IDE however it works.
So I'm afraid that there isn't a timer as I would like, so that every 1000 milliseconds an event is generated interrupting whatever processing is being done; even the Commodore 64 allowed the so-called "IRQ"! Windows, 40 years after Commodore, doesn't allow it. Patience... Commodore 64 wins; MsWindows loses!

I think you need to redesign the way your app does its processing (whatever that may be), possibly unloading it to a different thread (ActiveX EXE) and then you signal that thread if you want to interrupt it before it's done.

(reference post 31) :
I've struggled with when to use MultiThread for years. Maybe an explanationfrom one of my a programs might help?.
App1 receives realtime data from a server. Think of this as Thread-1. App1 also sends that data (XProcess) to App2 so that data can be plotted in a Picturebox on a Form. Think of App2 as Thread-2. When App2 receives the data from App1, that calls the function (main routine) to plot the data. Since the data is received faster than it can be plotted, a buffer is used to hold the data, so a lag in plotting occurs.
App2 also has a set of tools the user can use to either overlay, lookat, or extract the data from the Picturebox -- User is now using the Mouse.
So the Multithread question is, will putting the User use of the Mouse on a separate thread be of benefit? I said not. App2 and the Mouse both must have access to the picturebox. The plot routine and the tool routines (use of mouse) can NOT have access to the picturebox at the same time. So a priority must be established -- who goes first. This requires the stopping and restarting of either the plot or delaying the users mouse usage. Having the tools calculations on a separate thread, IMHO gains nothing. So a simple boolean to stop and start was used instead of a third thread for making the calculation needed for the tools. HTH

Code:

---

Will produce a timer error accumulation, 10 times delay of 1 second, the final error reached about 6 milliseconds
Cumulative time: 10005.4726 ms
1, time: 999.5706 milliseconds
2, time: 1001.004 milliseconds
3, time: 999.9972 milliseconds
4, time: 1000.9968 milliseconds
5, time: 1001.0024 milliseconds
6, time: 1000.0044 milliseconds
7, time: 1000.0083 milliseconds
8, time: 1000.9891 milliseconds
9, time: 1000.9963 milliseconds
10, time: 1000.9035 milliseconds

---

Code:

---

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Const WAIT_ABANDONED& = &H80&
Private Const WAIT_ABANDONED_0& = &H80&
Private Const WAIT_FAILED& = -1&
Private Const WAIT_IO_COMPLETION& = &HC0&
Private Const WAIT_OBJECT_0& = 0
Private Const WAIT_OBJECT_1& = 1
Private Const WAIT_TIMEOUT& = &H102&
Private Const INFINITE = &HFFFF
Private Const QS_HOTKEY& = &H80
Private Const QS_KEY& = &H1
Private Const QS_MOUSEBUTTON& = &H4
Private Const QS_MOUSEMOVE& = &H2
Private Const QS_PAINT& = &H20
Private Const QS_POSTMESSAGE& = &H8
Private Const QS_SENDMESSAGE& = &H40
Private Const QS_TIMER& = &H10
Private Const ERROR_ALREADY_EXISTS = 183&
Private Const QS_MOUSE& = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Private Const QS_INPUT& = (QS_MOUSE Or QS_KEY)
Private Const QS_ALLEVENTS& = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)
Private Const QS_ALLINPUT& = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)

Private Const UNITS = 4294967296#
Private Const MAX_LONG = -2147483648#

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 OpenWaitableTimer _
                Lib "kernel32" _
                Alias "OpenWaitableTimerA" (ByVal dwDesiredAccess As Long, _
                                            ByVal bInheritHandle 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 WaitForSingleObject _
                Lib "kernel32" (ByVal hHandle As Long, _
                                ByVal dwMilliseconds 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 mlTimer As Long
Sub StartTimer4()
    Randomize
    mlTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer" & Format$(Now(), "NNSS") & Int(Rnd * 10000))
    If Err.LastDllError = ERROR_ALREADY_EXISTS Then
    MsgBox "TIMER ERR"
    End If
End Sub
Sub CloseTimer4()

    On Error Resume Next

    If mlTimer <> 0 Then CloseHandle mlTimer
End Sub

Public Sub WaitCounts(MilliSeconds As Currency, Counts As Long)
    On Error GoTo ErrHandler
    Dim ft          As FILETIME
    Dim lBusy      As Long
    Dim lRet        As Long
    Dim dblDelay    As Double
    Dim dblDelayLow As Double
   

   
 
        ft.dwLowDateTime = -1
        ft.dwHighDateTime = -1
        lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, 0)
 
    'CDbl
    dblDelay = CCur(MilliSeconds) * 10000#
   
    ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1
    dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))
   
    If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLow
   
    ft.dwLowDateTime = CLng(dblDelayLow)
    Dim ID As Long
    Dim UsedC() As Currency, StartC As Currency
    ReDim UsedC(0 To Counts)
    QueryPerformanceCounter CPUv1
    StartC = CPUv1
    lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, False)
   
    Do While True
        lBusy = MsgWaitForMultipleObjects(1, mlTimer, False, INFINITE, QS_ALLINPUT&)
        If lBusy = WAIT_OBJECT_0 Then
            ID = ID + 1
              QueryPerformanceCounter CPUv2
         
            UsedC(ID) = CPUv2
            If ID = Counts Then Exit Do
            'QueryPerformanceCounter CPUv1
            CPUv1 = CPUv2
            SetWaitableTimer mlTimer, ft, 0, 0, 0, False
        Else
        DoEvents
        End If
     
    Loop
   
'    CloseHandle mlTimer
'    mlTimer = 0
Dim i As Long
UsedC(0) = StartC

Debug.Print "All UsedTime?" & (CPUv2 - StartC) / MsCount & "ms"
For i = 1 To 10
    Debug.Print i & ",Used?" & (UsedC(i) - UsedC(i - 1)) / MsCount & "ms"
Next
    Exit Sub
   
ErrHandler:
    Err.Raise Err.Number, Err.Source, "[clsWaitableTimer.Wait]" & Err.Description
End Sub

---

Code:

---


Private Sub Form_Load()
timeBeginPeriod 1
 

StartTimer4
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
CloseTimer4
End Sub

---

You can also create multiple timer objects, use ID control, modify the timing interval, and delete the timer.
General MsgWaitForMultipleObjects monitoring multiple timer trigger. This approach is also suitable for handling a loop check independently in multiple threads.

Code:

---

Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long '???????

 Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long
 Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long
 Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
 Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
 Public Const INFINITE As Long = -1&, QS_ALLINPUT As Long = &H4FF&

Sub Puase(ByVal Milliseconds As Currency)
    Dim hTimer As Long
    hTimer = CreateWaitableTimerW
    Call SetWaitableTimer(hTimer, CCur(-Milliseconds))
    Do While MsgWaitForMultipleObjects(1&, hTimer, 0&, INFINITE, QS_ALLINPUT)
        DoEvents
    Loop
    CloseHandle hTimer
End Sub

---

Code:

---

Private Sub Form_Load()
 
timeBeginPeriod 1

End Sub

Private Sub Command1_Click()

Puase 1000

End Sub

---

Quote:

---

Originally Posted by xiaoyao

Code:

---

Will produce a timer error accumulation, 10 times delay of 1 second, the final error reached about 6 milliseconds
Cumulative time: 10005.4726 ms
1, time: 999.5706 milliseconds
2, time: 1001.004 milliseconds
3, time: 999.9972 milliseconds
4, time: 1000.9968 milliseconds
5, time: 1001.0024 milliseconds
6, time: 1000.0044 milliseconds
7, time: 1000.0083 milliseconds
8, time: 1000.9891 milliseconds
9, time: 1000.9963 milliseconds
10, time: 1000.9035 milliseconds

---

Code:

---

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Const WAIT_ABANDONED& = &H80&
Private Const WAIT_ABANDONED_0& = &H80&
Private Const WAIT_FAILED& = -1&
Private Const WAIT_IO_COMPLETION& = &HC0&
Private Const WAIT_OBJECT_0& = 0
Private Const WAIT_OBJECT_1& = 1
Private Const WAIT_TIMEOUT& = &H102&
Private Const INFINITE = &HFFFF
Private Const QS_HOTKEY& = &H80
Private Const QS_KEY& = &H1
Private Const QS_MOUSEBUTTON& = &H4
Private Const QS_MOUSEMOVE& = &H2
Private Const QS_PAINT& = &H20
Private Const QS_POSTMESSAGE& = &H8
Private Const QS_SENDMESSAGE& = &H40
Private Const QS_TIMER& = &H10
Private Const ERROR_ALREADY_EXISTS = 183&
Private Const QS_MOUSE& = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Private Const QS_INPUT& = (QS_MOUSE Or QS_KEY)
Private Const QS_ALLEVENTS& = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)
Private Const QS_ALLINPUT& = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)

Private Const UNITS = 4294967296#
Private Const MAX_LONG = -2147483648#

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 OpenWaitableTimer _
                Lib "kernel32" _
                Alias "OpenWaitableTimerA" (ByVal dwDesiredAccess As Long, _
                                            ByVal bInheritHandle 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 WaitForSingleObject _
                Lib "kernel32" (ByVal hHandle As Long, _
                                ByVal dwMilliseconds 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 mlTimer As Long
Sub StartTimer4()
    Randomize
    mlTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer" & Format$(Now(), "NNSS") & Int(Rnd * 10000))
    If Err.LastDllError = ERROR_ALREADY_EXISTS Then
    MsgBox "TIMER ERR"
    End If
End Sub
Sub CloseTimer4()

    On Error Resume Next

    If mlTimer <> 0 Then CloseHandle mlTimer
End Sub

Public Sub WaitCounts(MilliSeconds As Currency, Counts As Long)
    On Error GoTo ErrHandler
    Dim ft          As FILETIME
    Dim lBusy      As Long
    Dim lRet        As Long
    Dim dblDelay    As Double
    Dim dblDelayLow As Double
   

   
 
        ft.dwLowDateTime = -1
        ft.dwHighDateTime = -1
        lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, 0)
 
    'CDbl
    dblDelay = CCur(MilliSeconds) * 10000#
   
    ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1
    dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))
   
    If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLow
   
    ft.dwLowDateTime = CLng(dblDelayLow)
    Dim ID As Long
    Dim UsedC() As Currency, StartC As Currency
    ReDim UsedC(0 To Counts)
    QueryPerformanceCounter CPUv1
    StartC = CPUv1
    lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, False)
   
    Do While True
        lBusy = MsgWaitForMultipleObjects(1, mlTimer, False, INFINITE, QS_ALLINPUT&)
        If lBusy = WAIT_OBJECT_0 Then
            ID = ID + 1
              QueryPerformanceCounter CPUv2
         
            UsedC(ID) = CPUv2
            If ID = Counts Then Exit Do
            'QueryPerformanceCounter CPUv1
            CPUv1 = CPUv2
            SetWaitableTimer mlTimer, ft, 0, 0, 0, False
        Else
        DoEvents
        End If
     
    Loop
   
'    CloseHandle mlTimer
'    mlTimer = 0
Dim i As Long
UsedC(0) = StartC

Debug.Print "All UsedTime?" & (CPUv2 - StartC) / MsCount & "ms"
For i = 1 To 10
    Debug.Print i & ",Used?" & (UsedC(i) - UsedC(i - 1)) / MsCount & "ms"
Next
    Exit Sub
   
ErrHandler:
    Err.Raise Err.Number, Err.Source, "[clsWaitableTimer.Wait]" & Err.Description
End Sub

---

Code:

---


Private Sub Form_Load()
timeBeginPeriod 1
 

StartTimer4
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
CloseTimer4
End Sub

---

---

Sorry, but I didn't understand how to make it work...

Quote:

---

Originally Posted by fabel358

Sorry, but I didn't understand how to make it work...

---

HOW DO YOU WORK FOR?
WaitCounts (1000,10)

or put code in timer2.cls

Code:

---


Public Event Tick()
Dim IsEnabled As Boolean
 
Public Property Get Enabled() As Boolean
    Enabled = IsEnabled
End Property

Public Property Let Enabled(ByVal vNewValue As Boolean)
    IsEnabled = vNewValue

if IsEnabled  then

  Do While IsEnabled  'IsEnabled  =false for stop timer
        lBusy = MsgWaitForMultipleObjects(1, mlTimer, False, INFINITE, QS_ALLINPUT&)
        If lBusy = WAIT_OBJECT_0 Then
            ID = ID + 1
 
 
            If ID = Counts Then Exit Do
 
                RaiseEvent Tick
            SetWaitableTimer mlTimer, ft, 0, 0, 0, False
        Else
        DoEvents
        End If
     
    Loop
end if
End Property

---

Set a timer to generate an event every 1 second, exit after 10 times, you can also add other variable markers to force the end

Moudle1.bas code:
Public EndExe As Boolean



clsTimerEx.cls

Code:

---

Option Explicit
Public Event Timer()
   
Dim m_idTimer As Long
Dim m_Enabled As Boolean
Dim m_Interval As Long
Dim m_lTimerProc As Long



Private Declare Function timeBeginPeriod Lib "winmm.dll" _
  (ByVal uPeriod As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Private Declare Function timeEndPeriod Lib "winmm.dll" _
  (ByVal uPeriod As Long) As Long
 
 
Private Type FILETIME

dwLowDateTime As Long
dwHighDateTime As Long

End Type

Private Const WAIT_ABANDONED& = &H80&

Private Const WAIT_ABANDONED_0& = &H80&

Private Const WAIT_FAILED& = -1&

Private Const WAIT_IO_COMPLETION& = &HC0&

Private Const WAIT_OBJECT_0& = 0

Private Const WAIT_OBJECT_1& = 1

Private Const WAIT_TIMEOUT& = &H102&

Private Const INFINITE = &HFFFF

Private Const ERROR_ALREADY_EXISTS = 183&

Private Const QS_HOTKEY& = &H80

Private Const QS_KEY& = &H1

Private Const QS_MOUSEBUTTON& = &H4

Private Const QS_MOUSEMOVE& = &H2

Private Const QS_PAINT& = &H20

Private Const QS_POSTMESSAGE& = &H8

Private Const QS_SENDMESSAGE& = &H40

Private Const QS_TIMER& = &H10

Private Const QS_MOUSE& = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)

Private Const QS_INPUT& = (QS_MOUSE Or QS_KEY)

Private Const QS_ALLEVENTS& = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)

Private Const QS_ALLINPUT& = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)

Private Const UNITS = 4294967296#

Private Const MAX_LONG = -2147483648#

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 OpenWaitableTimer _
Lib "kernel32" _
Alias "OpenWaitableTimerA" (ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle 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) As Boolean

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Function WaitForSingleObject _
Lib "kernel32" (ByVal hHandle As Long, _
ByVal dwMilliseconds 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 mlTimer As Long

Dim lRet As Long, ft As FILETIME
Dim lBusy As Long
Public ??????? As Currency, ?? As Currency
Sub NewTimer()
    mlTimer = CreateWaitableTimer(0, True, "ClsTimer" & ObjPtr(Me))
    If Err.LastDllError <> ERROR_ALREADY_EXISTS Then
        Dim ft As FILETIME
        ft.dwLowDateTime = -1
        ft.dwHighDateTime = -1
        lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, 0)
    End If
End Sub
'Sub Wait(SleepTime As Long)  '??????
''?????????????????Sleep 1000????????Sleep??????1?
'On Error GoTo ErrHandler
'If mlTimer = 0 Then NewTimer 'Exit Sub
'Dim dblDelay As Double
'
'Dim dblDelayLow As Double
'
'dblDelay = CDbl(SleepTime) * 10000#
'ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1
'dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))
'
'If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLow
'ft.dwLowDateTime = CLng(dblDelayLow)
'
'
'    lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, False)
'    lBusy = -1
'    Do While (lBusy <> WAIT_OBJECT_0 And Not EndExe)
'    lBusy = MsgWaitForMultipleObjects(1, mlTimer, False, INFINITE, QS_ALLINPUT&)
'        If lBusy < 1 Then
'            Exit Do
'        Else
'            DoEvents
'        End If
'    Loop
''Debug.Print "DoeventsCount=" & DoeventsCount
'Exit Sub
'
'ErrHandler:
'ERR.Raise ERR.Number, ERR.Source, "[clsWaitableTimer.Wait]" & ERR.Description
'End Sub
'
'Function StopTimer()
'CancelWaitableTimer ByVal mlTimer
'lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, False)
'End Function
Public Sub Doevents2Start(Optional SleepTime As Long = 1) '??????
'?????????????????Sleep 1000????????Sleep??????1?
On Error GoTo ErrHandler

Dim dblDelay As Double

Dim dblDelayLow As Double

mlTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer" & Format$(Now(), "NNSS"))

If Err.LastDllError <> ERROR_ALREADY_EXISTS Then
ft.dwLowDateTime = -1
ft.dwHighDateTime = -1
lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, 0)
End If

dblDelay = CDbl(SleepTime) * 10000#
ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1
dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))

If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLow

ft.dwLowDateTime = CLng(dblDelayLow)


Exit Sub

ErrHandler:
Err.Raise Err.Number, Err.Source, "[clsWaitableTimer.Wait]" & Err.Description
End Sub
Function WaitTimerN_ms() As Long '??????????????

    lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, False)
    lBusy = -1
    Do While lBusy <> WAIT_OBJECT_0
    lBusy = MsgWaitForMultipleObjects(1, mlTimer, False, INFINITE, QS_ALLINPUT&)
        If lBusy < 1 Then
            Exit Do
        Else

            DoEvents
        End If
    Loop

End Function

Public Sub CloseTimer() '????????????
    On Error Resume Next
    If mlTimer <> 0 Then
        m_Interval = 0
        m_Enabled = False
        CloseHandle mlTimer
        mlTimer = 0
    End If
End Sub

Public Property Get Interval() As Long
    Interval = m_Interval
End Property
Public Property Let Interval(ByVal SleepTime As Long)
    If SleepTime >= 0 Then
        m_Interval = SleepTime
       
        Dim dblDelay As Double
        Dim dblDelayLow As Double
        dblDelay = CDbl(SleepTime) * 10000#
        ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1
        dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))
       
        If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLow
       
        ft.dwLowDateTime = CLng(dblDelayLow)
End If
End Property
   
Public Property Get Enabled() As Boolean
    Enabled = m_Enabled
End Property
Public Property Let Enabled(ByVal New_Value As Boolean)
    m_Enabled = New_Value
    If mlTimer = 0 Then NewTimer
    'If m_idTimer <> 0 Then KillTimer 0, m_idTimer
    If New_Value And m_Interval > 0 Then
        While m_Interval > 0 And m_Enabled
            WaitTimerN_ms '???N????????
            If m_Enabled Then RaiseEvent Timer
        Wend
    End If
End Property



Private Sub Class_Initialize()
    timeBeginPeriod 1
    m_Interval = 0
End Sub
   
Private Sub Class_Terminate()
 
    CloseTimer
End Sub

---

form1.frm

Code:

---

Option Explicit
Dim WithEvents TimerEx As clsTimerEx

'add two buttons, two label control, add timer1 ,timer2 control




 Private Sub TimerEx_Timer()
    If Not TimerEx.Enabled Then
                Exit Sub 'Prevent the timer from failing while still operating the control detective
                '???????????????
        End
    End If
    Label1.Caption = "TimerEx-" & Now
End Sub

Private Sub Form_Load()
    Command1.Caption = "Start TimerEx"
    Command2.Caption = "Stop TimerEx"

    Set TimerEx = New clsTimerEx
    TimerEx.Interval = 2000
   
    Timer1.Interval = 500
    Timer1.Enabled = True
   
    Timer2.Interval = 500
    Timer2.Enabled = True 'start TimerEx by Button1 or by Timer2
   
End Sub

Private Sub Timer2_Timer()
    Timer2.Enabled = False
    Command1_Click
End Sub

Private Sub Command1_Click() 'start timer
    Command1.Enabled = False
    Label1.Caption = "TimerEx wait"
    Label1.Refresh
    DoEvents
    TimerEx.Enabled = True

    If Not EndExe Then Command1.Enabled = True
End Sub
Private Sub Command2_Click() 'StopTimer
    TimerEx.Enabled = False
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    On Error Resume Next
    EndExe = True
    TimerEx.CloseTimer
End Sub


Private Sub Timer1_Timer()
    Label2.Caption = "vb6 Timer :" & Now
End Sub
Private Sub Command3_Click()
    MsgBox "it's button 3"
End Sub

---

or start Timer From Thread:

Code:

---

Sub RunInThread2()
    Call CreateThread(0, 0, AddressOf ThreadStartTimer_NeedIntvb6, ByVal 0&, 0&, 0&)
End Sub
Sub ThreadStartTimer_NeedIntvb6()
    CreateIExprSrvObj 0, 4, 0

    intVB6Header 'Initialize multithreading parameters
    '*** code *** Initialize multithreading parameters


    Set form1.TimerEx = New clsTimerEx
    form1.TimerEx.Interval = 2000
    form1.TimerEx.Enabled = True
End Sub

---