Results 1 to 38 of 38

Thread: VB6 - A very precise timer using Multithreading

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Feb 2002
    Location
    Canada, Toronto
    Posts
    5,803

    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:
    Name:  SingleThread.JPG
Views: 15120
Size:  17.6 KB

    QPTimerTestMultiThread - Multi Thread app:
    Name:  MultiThread.JPG
Views: 14579
Size:  28.2 KB
    Attached Files Attached Files
    Last edited by CVMichael; Apr 13th, 2009 at 12:13 PM.

  2. #2
    New Member Eranga Pilimatalawwe's Avatar
    Join Date
    Mar 2008
    Location
    Srilanka
    Posts
    6

    Re: VB6 - A very precise timer using Multithreading

    Can Some One Please Send Me A Working Copy Of The Timer? My Email Is brainiacguy@hotmail.com
    Eventor

    The Best Lesson Life Has Taught Me Is That The Idiots In Many Cases Are Right. ~ Winston Churcill

  3. #3

    Thread Starter
    PowerPoster
    Join Date
    Feb 2002
    Location
    Canada, Toronto
    Posts
    5,803

    Re: VB6 - A very precise timer using Multithreading

    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

  4. #4
    Member Senacharim's Avatar
    Join Date
    Feb 2008
    Posts
    56

    Re: VB6 - A very precise timer using Multithreading

    Quote Originally Posted by Eranga Pilimatalawwe
    Can Some One Please Send Me A Working Copy Of The Timer? My Email Is brainiacguy@hotmail.com
    Was the link to the zip file too complicated for you??

  5. #5

    Thread Starter
    PowerPoster
    Join Date
    Feb 2002
    Location
    Canada, Toronto
    Posts
    5,803

    Re: VB6 - A very precise timer using Multithreading

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

  6. #6
    New Member
    Join Date
    Nov 2006
    Posts
    4

    Re: VB6 - A very precise timer using Multithreading

    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

  7. #7

    Thread Starter
    PowerPoster
    Join Date
    Feb 2002
    Location
    Canada, Toronto
    Posts
    5,803

    Re: VB6 - A very precise timer using Multithreading

    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:

    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...
    Last edited by CVMichael; May 8th, 2008 at 11:15 AM.

  8. #8
    New Member
    Join Date
    Nov 2006
    Posts
    4

    Re: VB6 - A very precise timer using Multithreading

    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

  9. #9

    Thread Starter
    PowerPoster
    Join Date
    Feb 2002
    Location
    Canada, Toronto
    Posts
    5,803

    Re: VB6 - A very precise timer using Multithreading

    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
    Attached Files Attached Files

  10. #10
    Fanatic Member coolcurrent4u's Avatar
    Join Date
    Apr 2008
    Location
    *****
    Posts
    993

    Re: VB6 - A very precise timer using Multithreading

    how do i add the reference to the ThreadTemplate?

  11. #11

    Thread Starter
    PowerPoster
    Join Date
    Feb 2002
    Location
    Canada, Toronto
    Posts
    5,803

    Re: VB6 - A very precise timer using Multithreading

    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.

  12. #12
    Freelancer akhileshbc's Avatar
    Join Date
    Jun 2008
    Location
    Trivandrum, Kerala, India
    Posts
    7,652

    Re: VB6 - A very precise timer using Multithreading

    Thanks CVMichael ...

    If my post was helpful to you, then express your gratitude using Rate this Post.
    And if your problem is SOLVED, then please Mark the Thread as RESOLVED (see it in action - video)
    My system: AMD FX 6100, Gigabyte Motherboard, 8 GB Crossair Vengance, Cooler Master 450W Thunder PSU, 1.4 TB HDD, 18.5" TFT(Wide), Antec V1 Cabinet

    Social Group: VBForums - Developers from India


    Skills: PHP, MySQL, jQuery, VB.Net, Photoshop, CodeIgniter, Bootstrap,...

  13. #13
    Hyperactive Member
    Join Date
    Jan 1999
    Location
    Fort Worth, Texas, USA
    Posts
    264

    Re: VB6 - A very precise timer using Multithreading

    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!

  14. #14
    Hyperactive Member
    Join Date
    Jan 1999
    Location
    Fort Worth, Texas, USA
    Posts
    264

    Re: VB6 - A very precise timer using Multithreading

    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.

  15. #15

    Thread Starter
    PowerPoster
    Join Date
    Feb 2002
    Location
    Canada, Toronto
    Posts
    5,803

    Re: VB6 - A very precise timer using Multithreading

    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...
    Last edited by CVMichael; Aug 24th, 2015 at 01:16 PM.

  16. #16

    Thread Starter
    PowerPoster
    Join Date
    Feb 2002
    Location
    Canada, Toronto
    Posts
    5,803

    Re: VB6 - A very precise timer using Multithreading

    Quote Originally Posted by Ken Whiteman View Post
    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.

  17. #17
    Hyperactive Member
    Join Date
    Jan 1999
    Location
    Fort Worth, Texas, USA
    Posts
    264

    Re: VB6 - A very precise timer using Multithreading

    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-

  18. #18
    Addicted Member
    Join Date
    Nov 2016
    Location
    GB
    Posts
    157

    Re: VB6 - A very precise timer using Multithreading

    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?

  19. #19
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,632

    Talking Re: VB6 - A very precise timer using Multithreading

    Quote Originally Posted by fabel358 View Post
    (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.

  20. #20
    Addicted Member
    Join Date
    Nov 2016
    Location
    GB
    Posts
    157

    Re: VB6 - A very precise timer using Multithreading

    Quote Originally Posted by VanGoghGaming View Post
    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"

  21. #21
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,632

    Talking Re: VB6 - A very precise timer using Multithreading

    Quote Originally Posted by fabel358 View Post
    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.

  22. #22
    Addicted Member
    Join Date
    Nov 2016
    Location
    GB
    Posts
    157

    Re: VB6 - A very precise timer using Multithreading

    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.

  23. #23
    Addicted Member
    Join Date
    Nov 2016
    Location
    GB
    Posts
    157

    Re: VB6 - A very precise timer using Multithreading

    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.

  24. #24
    Addicted Member
    Join Date
    Nov 2016
    Location
    GB
    Posts
    157

    Re: VB6 - A very precise timer using Multithreading

    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.

  25. #25

  26. #26
    Addicted Member
    Join Date
    Nov 2016
    Location
    GB
    Posts
    157

    Re: VB6 - A very precise timer using Multithreading

    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!

  27. #27

    Thread Starter
    PowerPoster
    Join Date
    Feb 2002
    Location
    Canada, Toronto
    Posts
    5,803

    Re: VB6 - A very precise timer using Multithreading

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

  28. #28
    Addicted Member
    Join Date
    Nov 2016
    Location
    GB
    Posts
    157

    Re: VB6 - A very precise timer using Multithreading

    Quote Originally Posted by CVMichael View Post
    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.
    Last edited by fabel358; May 1st, 2024 at 09:25 AM.

  29. #29
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,632

    Talking Re: VB6 - A very precise timer using Multithreading

    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.

  30. #30
    Addicted Member
    Join Date
    Nov 2016
    Location
    GB
    Posts
    157

    Re: VB6 - A very precise timer using Multithreading

    Quote Originally Posted by VanGoghGaming View Post
    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!
    Last edited by fabel358; May 2nd, 2024 at 02:34 AM.

  31. #31
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,632

    Re: VB6 - A very precise timer using Multithreading

    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.

  32. #32
    Fanatic Member
    Join Date
    Feb 2017
    Posts
    879

    Re: VB6 - A very precise timer using Multithreading

    (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
    Last edited by vb6forever; May 2nd, 2024 at 08:01 PM.

  33. #33
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,948

    Re: VB6 - A very precise timer using Multithreading

    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

  34. #34
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,948

    Re: VB6 - A very precise timer using Multithreading

    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
    Last edited by xiaoyao; May 28th, 2024 at 11:08 PM.

  35. #35
    Addicted Member
    Join Date
    Nov 2016
    Location
    GB
    Posts
    157

    Re: VB6 - A very precise timer using Multithreading

    Quote Originally Posted by xiaoyao View Post
    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...

  36. #36
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,948

    Re: VB6 - A very precise timer using Multithreading

    Quote Originally Posted by fabel358 View Post
    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
    Last edited by xiaoyao; May 29th, 2024 at 11:58 AM.

  37. #37
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,948

    Re: VB6 - A very precise timer using Multithreading

    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
    Attached Files Attached Files
    Last edited by xiaoyao; May 29th, 2024 at 12:30 PM.

  38. #38
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,948

    Re: VB6 - A very precise timer using Multithreading

    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width