PHP User Warning: fetch_template() calls should be replaced by the vB_Template class. Template name: bbcode_highlight in ..../includes/functions.php on line 4197
CTimer class module with ITimer interface-VBForums
Results 1 to 10 of 10

Thread: CTimer class module with ITimer interface

Hybrid View

  1. #1

    Thread Starter
    Frenzied Member
    Join Date
    Jun 2012
    Posts
    1,398

    CTimer class module with ITimer interface

    This is a modified version of the CTimer class module from Paul Caton's "cTimer - module-less, IDE safe, machine code timer thunk".
    The code has been simplified and the assembly thunk is also enhanced.

    There are many class module Timers out there, so why another CTimer?

    Because I was not 100% satisfied by either one.
    My most preferred CTimer was from Paul Caton, but were botherd because the 'lElapsedMS' parameter was not reliable as it could go negative.
    The only one I know where this problem does not exist is Merri's SelfTimer class module, however there I am bothered as it is event driven and not interface driven. Also the assembly is working with private functions (ordinal address), where I have a dislike on them since I made the expierence that they can go broken in a ActiveX project after a "Binary Compatibility" compile. (means first compile works, but further ones are broken)

    The benefit of interface driven "events" is that these are more efficient and it also ensures that the event will be fired. (no 'EventsFrozen' scenario)
    Only downside is that this is a "two file" solution, but this is acceptable in my opinion.

    So, what is the difference in this CTimer compared to the original from Paul Caton?
    The original ITimer interface looks like this:
    Code:
    Public Sub Proc(ByVal lElapsedMS As Long, ByVal lTimerID As Long)
    Whereas my is:
    Code:
    Public Sub Timer(ByVal Key As String, ByVal ElapsedTime As Currency)
    So instead of a ID (Long), there is a Key (String) to identify multiple timers on one Owner.
    Important point is that the ElapsedTime parameter is now as 'Currency' and not as 'Long' anymore to be able to represent an unsigned long integer.
    So in fact the ElapsedTime value can be from 0 to 4.294.967.295. When it reaches 4.294.967.295 it wraps to 0 again.
    This approach ensures that the value is never negative (important) and the timer can run 49.7 days until it wraps to 0.
    Example: StartTickCount is -1 (right before GetTickCount wraps internally; unsigned value would be 4,294,967,295) and CurrentTickCount is 101 (after GetTickCount wrapped internally) the result in ElapsedTime (As Currency) will be: 102.
    So that means it does not matter where GetTickCount currently is, the ElapsedTime will always work.
    Only when the timer ran 49.7 days continuous, then the timer starts from 0 again. (rare case)
    The assembly code was modified therefore to get the new results in the ITimer call.

    Properties:
    ID: Returns an internal identification of a timer. (Default value)
    Interval: Returns/sets the number of milliseconds between calls to a timer event.

    Functions:
    Create(ByVal Owner As ITimer, Optional ByVal Key As String) As Boolean: Creates a new timer.
    Terminate() As Boolean: Terminates the current timer.

    There is no 'Enabled' property. To determine if the timer is running just check if 'ID' is <> 0.
    The 'Interval' must be > 0, as otherwise the 'Create' function will return False and 'ID' remains 0.
    To make a reset of the ElapsedTime just set 'Interval' again. (can be changed even if the timer is already created)

    In the attachment is the demo project included.

    The source code (incl. assembler source code) of the project can also be viewed on GitHub.
    Attached Files Attached Files
    Last edited by Krool; Dec 30th, 2019 at 09:13 AM.

  2. #2
    Frenzied Member
    Join Date
    Sep 2012
    Posts
    1,854

    Re: CTimer class module with ITimer interface

    It is very useful, thanks very much.

    I often use Timer instead of Subclass.

  3. #3

    Thread Starter
    Frenzied Member
    Join Date
    Jun 2012
    Posts
    1,398

    Re: CTimer class module with ITimer interface

    With this little trick it is even possible to circumvent the 49.7 days limitation for the ElapsedTime argument.

    Code:
    Private TotalElapsedTime As Currency, LastElapsedTime As Currency
    
    Private Sub ITimer_Timer(ByVal Key As String, ByVal ElapsedTime As Currency)
    If ElapsedTime < LastElapsedTime Then
        TotalElapsedTime = TotalElapsedTime + (4294967295@ - LastElapsedTime)
        LastElapsedTime = 0
    End If
    TotalElapsedTime = TotalElapsedTime + (ElapsedTime - LastElapsedTime)
    LastElapsedTime = ElapsedTime
    
    Debug.Print TotalElapsedTime
    
    End Sub
    Now the TotalElapsedTime will be meaningful for an infinite time. (4,305,982.1 days)

    Of course when resetting the timer (.Terminate/.Create or set 'Interval' again) it is necessary to clear the private variables TotalElapsedTime and LastElapsedTime.
    Last edited by Krool; Aug 18th, 2017 at 05:38 PM.

  4. #4

    Thread Starter
    Frenzied Member
    Join Date
    Jun 2012
    Posts
    1,398

    Re: CTimer class module with ITimer interface

    Update released.

    I noticed that on some environments the memory block (run-time code) was not working/executing.

    The fix was to create the ASM with VirtualAlloc and PAGE_EXECUTE_READWRITE instead of HeapAlloc.
    It was a grave error.. which got now fixed. Sorry.
    Last edited by Krool; Dec 28th, 2019 at 08:16 AM.

  5. #5

    Thread Starter
    Frenzied Member
    Join Date
    Jun 2012
    Posts
    1,398

    Re: CTimer class module with ITimer interface

    Update released.

    Runs now without run-time error in 32-bit VBA.
    Last edited by Krool; Dec 30th, 2019 at 11:56 AM.

  6. #6
    Addicted Member
    Join Date
    Dec 2008
    Location
    Argentina
    Posts
    227

    Re: CTimer class module with ITimer interface

    hi krool, I like your class, my question is I want to pass it to a usercontrol for my own use, but I have not been able to find what is the point that I must modify so that it works in the UC, in other ASM I changed & H1C for & H7A4 for User control or for a form by & H6F8

    Code:
    Option Explicit
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    Private Declare Function VirtualAlloc Lib "kernel32" (ByRef lpAddress As Long, ByVal dwSize As Long, ByVal flAllocType As Long, ByVal flProtect As Long) As Long
    Private Declare Function VirtualFree Lib "kernel32" (ByRef lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
    Private Const MEM_COMMIT As Long = &H1000
    Private Const MEM_RELEASE As Long = &H8000&
    Private Const PAGE_EXECUTE_READWRITE As Long = &H40
    Private Const PATCH_EBMODE As Long = 3
    Private Const PATCH_STARTTIME As Long = 21
    Private Const PATCH_KEY As Long = 36
    Private Const PATCH_OBJECTPOINTER As Long = 41
    Private Const PATCH_KILLTIMER As Long = 61
    Private ASMWrapper As Long
    Private PropID As Long
    
    Public Sub Timer(ByVal Key As Long, ByVal ElapsedTime As Currency)
        Debug.Print Now
    End Sub
    
    
    Public Sub CreateTimer(Interval As Long)
        If PropID <> 0 Then DestroyTimer
        MemOffset32(ASMWrapper, PATCH_STARTTIME) = GetTickCount()
        'MemOffset32(ASMWrapper, PATCH_KEY) = StrPtr(PropKey)
        MemOffset32(ASMWrapper, PATCH_OBJECTPOINTER) = ObjPtr(Me)
        PropID = SetTimer(0, 0, Interval, ASMWrapper)
    End Sub
    
    Public Sub DestroyTimer()
        If PropID <> 0 Then KillTimer 0, PropID
        PropID = 0
    End Sub
    
    Private Sub PatchProcAddress(ByVal ASMWrapper As Long, ByVal Offset As Long, ByVal LibName As String, ByVal ProcName As String)
        Dim ProcAddress As Long
        ProcAddress = GetProcAddress(GetModuleHandle(StrPtr(LibName)), ProcName)
        If ProcAddress <> 0 Then MemOffset32(ASMWrapper, Offset) = UnsignedAdd(ProcAddress, -UnsignedAdd(ASMWrapper, Offset) - 4)
    End Sub
    
    Private Property Get MemOffset32(ByVal Start As Long, ByVal Offset As Long) As Long
        CopyMemory MemOffset32, ByVal UnsignedAdd(Start, Offset), 4
    End Property
    
    Private Property Let MemOffset32(ByVal Start As Long, ByVal Offset As Long, ByVal Value As Long)
        CopyMemory ByVal UnsignedAdd(Start, Offset), Value, 4
    End Property
    
    Private Function UnsignedAdd(ByVal Start As Long, ByVal Incr As Long) As Long
        UnsignedAdd = ((Start Xor &H80000000) + Incr) Xor &H80000000
    End Function
    
    Private Function InIDE(Optional ByRef B As Boolean = True) As Boolean
        If B = True Then Debug.Assert Not InIDE(InIDE) Else B = True
    End Function
    
    Private Sub UserControl_Initialize()
        Dim ASM(0 To 66) As Byte
        ASM(0) = &HEB: ASM(1) = &HE: ASM(2) = &HE8: ASM(3) = &H0: ASM(4) = &H0
        ASM(5) = &H0: ASM(6) = &H0: ASM(7) = &H83: ASM(8) = &HF8: ASM(9) = &H2
        ASM(10) = &H74: ASM(11) = &H27: ASM(12) = &H85: ASM(13) = &HC0: ASM(14) = &H74
        ASM(15) = &H26: ASM(16) = &H8B: ASM(17) = &H44: ASM(18) = &H24: ASM(19) = &H10
        ASM(20) = &H2D: ASM(21) = &H0: ASM(22) = &H0: ASM(23) = &H0: ASM(24) = &H0
        ASM(25) = &H99: ASM(26) = &HBB: ASM(27) = &H10: ASM(28) = &H27: ASM(29) = &H0
        ASM(30) = &H0: ASM(31) = &HF7: ASM(32) = &HE3: ASM(33) = &H52: ASM(34) = &H50
        ASM(35) = &H68: ASM(36) = &H0: ASM(37) = &H0: ASM(38) = &H0: ASM(39) = &H0
        ASM(40) = &HB8: ASM(41) = &H0: ASM(42) = &H0: ASM(43) = &H0: ASM(44) = &H0
        ASM(45) = &H50: ASM(46) = &H8B: ASM(47) = &H0: ASM(48) = &HFF: ASM(49) = &H50
        ASM(50) = &H1C: ASM(51) = &HC2: ASM(52) = &H10: ASM(53) = &H0: ASM(54) = &H8B
        ASM(55) = &H4C: ASM(56) = &H24: ASM(57) = &HC: ASM(58) = &H51: ASM(59) = &H50
        ASM(60) = &HE8: ASM(61) = &H0: ASM(62) = &H0: ASM(63) = &H0: ASM(64) = &H0
        ASM(65) = &HEB: ASM(66) = &HF0
        ASMWrapper = VirtualAlloc(ByVal 0&, 67, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
        If ASMWrapper <> 0 Then
            CopyMemory ByVal ASMWrapper, ASM(0), 67
            If InIDE() = True Then
                If GetModuleHandle(StrPtr("vb6.exe")) = &H400000 Then
                    Call PatchProcAddress(ASMWrapper, PATCH_EBMODE, "vba6.dll", "EbMode")
                    CopyMemory ByVal ASMWrapper, &H9090, 2
                End If
            End If
            Call PatchProcAddress(ASMWrapper, PATCH_KILLTIMER, "user32.dll", "KillTimer")
        End If
    
    End Sub
    
    Private Sub UserControl_Terminate()
        If PropID <> 0 Then Me.DestroyTimer
        If ASMWrapper <> 0 Then VirtualFree ByVal ASMWrapper, 0, MEM_RELEASE
    End Sub
    Last edited by LeandroA; Jan 15th, 2020 at 10:56 PM.
    leandroascierto.com Visual Basic 6 projects

  7. #7

    Thread Starter
    Frenzied Member
    Join Date
    Jun 2012
    Posts
    1,398

    Re: CTimer class module with ITimer interface

    Quote Originally Posted by LeandroA View Post
    hi krool, I like your class, my question is I want to pass it to a usercontrol for my own use, but I have not been able to find what is the point that I must modify so that it works in the UC, in other ASM I changed & H1C for & H7A4 for User control or for a form by & H6F8
    The beauty of this class and interface driven approach is that it can be wrapped around easily and is very efficient.

    Below is a UCTimer which wraps CTimer and from outside it works like the VB.Timer
    So, if you don't mind to have 3 components (UCTimer, CTimer and ITimer) then this works pretty straight forward:

    Code:
    VERSION 5.00
    Begin VB.UserControl UCTimer 
       ClientHeight    =   3600
       ClientLeft      =   0
       ClientTop       =   0
       ClientWidth     =   4800
       InvisibleAtRuntime=   -1  'True
       ScaleHeight     =   3600
       ScaleWidth      =   4800
    End
    Attribute VB_Name = "UCTimer"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = True
    Attribute VB_PredeclaredId = False
    Attribute VB_Exposed = False
    Option Explicit
    Public Event Timer()
    Implements ITimer
    Private PropTimer As CTimer
    Private PropEnabled As Boolean
    Private PropInterval As Long
    
    Private Sub ITimer_Timer(ByVal Key As String, ByVal ElapsedTime As Currency)
    RaiseEvent Timer
    End Sub
    
    Private Sub UserControl_Initialize()
    Set PropTimer = New CTimer
    End Sub
    
    Private Sub UserControl_Terminate()
    Set PropTimer = Nothing
    End Sub
    
    Private Sub UserControl_InitProperties()
    PropEnabled = False
    PropInterval = 0
    End Sub
    
    Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    PropEnabled = PropBag.ReadProperty("Enabled", False)
    PropInterval = PropBag.ReadProperty("Interval", 0)
    Call CreateTimer
    End Sub
    
    Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "Enabled", PropEnabled, False
    PropBag.WriteProperty "Interval", PropInterval, 0
    End Sub
    
    Public Property Get Enabled() As Boolean
    Enabled = PropEnabled
    End Property
    
    Public Property Let Enabled(ByVal Value As Boolean)
    PropEnabled = Value
    Call CreateTimer
    End Property
    
    Public Property Get Interval() As Long
    Interval = PropInterval
    End Property
    
    Public Property Let Interval(ByVal Value As Long)
    If Value < 0 Then Err.Raise 380
    PropInterval = Value
    Call CreateTimer
    End Property
    
    Private Sub CreateTimer()
    If Ambient.UserMode = False Then Exit Sub
    If PropEnabled = True And PropInterval > 0 Then
        PropTimer.Interval = PropInterval
        If PropTimer.ID = 0 Then PropTimer.Create Me
    Else
        If PropTimer.ID <> 0 Then PropTimer.Terminate
    End If
    End Sub
    Last edited by Krool; Jan 17th, 2020 at 01:14 PM.

  8. #8
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,749

    Re: CTimer class module with ITimer interface

    In this CTimer implementaion you have to put Public Sub Timer as the *first* method after the IDispatch interface methods so its actually located in the 8-th slot of the (default) interface's virtual table.

    My suspicion is that for VB6 created user-controls, forms and property-pages the "base" classes these are "inherited" from already implement a massive amount of "intrinsic" methods past IDispatch interface, so the idea to place Public Sub Timer as the first method of the class fails.

    JFYI, here is a self-contained timer implementation that locates Public Sub Timer callback "dynamicly" on classes and VB6 user-controls, forms and property-pages as well, so that the callback is *not* fixed being first method after IDispatch interface, it can be placed anywhere in the class module source-code.

    The implementation is missing the bells and whistles of current CTimer -- no Key param and no Elapsed time on the callback -- as these can easily be emulated with member variables. For instance instead of registering a Key you can implement different callback methods per key (e.g. TimerForThis and TimerForOtherKey methods) and then manually calculate elapsed with QueryPerformanceFrequency/Counter with something like this

    thinBasic Code:
    1. Public Property Get TimerEx() As Double
    2.     Dim cFreq           As Currency
    3.     Dim cValue          As Currency
    4.    
    5.     Call QueryPerformanceFrequency(cFreq)
    6.     Call QueryPerformanceCounter(cValue)
    7.     TimerEx = cValue / cFreq
    8. End Property
    cheers,
    </wqw>

  9. #9
    Addicted Member
    Join Date
    Dec 2008
    Location
    Argentina
    Posts
    227

    Re: CTimer class module with ITimer interface

    hi wqweto, hi Krool, excuse me if I do not express myself correctly, but my idea is to use a timer built into a user control, to verify when the mouse leaves the usercontrol (windowless = true) I want to control the mouse exit, I do not want to use another external dependency (Module bas or class) only the usercontrol.
    it's really just for testing, I usually use Timer vb control, many colleagues told me to replace it with api, so I implemented the wqweto method, it works fine, but I haven't noticed any advantage, in fact the executable has uploaded some kb and in performance it consumes more memory than the version of the vb timer control, that is why I am in this thread to test its method, which I do not think it varies much with respect to that of wqweto, I still maintain that it is better to use the timer control for my case But my colleagues insist that I replace it with api, what do you think?

    by the way don't be offended by my comment, both classes are excellent (wqweto,Krool), I mean that "maybe" in my case only one vbtimer is enough for me
    Last edited by LeandroA; Jan 18th, 2020 at 03:06 AM.
    leandroascierto.com Visual Basic 6 projects

  10. #10
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,749

    Re: CTimer class module with ITimer interface

    > in fact the executable has uploaded some kb

    The Timer built-in control is already compiled in the runtime while timer thunk impl is 150 lines of VB6 code so probably 10-20KB compiled.

    > and in performance it consumes more memory than the version of the vb timer control

    Doubt it. For timer thunk sizeof_InstanceData = 24 which probably has to be 16-bytes aligned by CoTaskMemAlloc allocator to about 32 bytes per timer instance.

    Timer thunk is implemented differently than the UserControl you pasted here. In your UserControl_Initialize you call VirtualAlloc and copy the thunk in this memory chunk for *each and every* instance of the user-control.

    The timer thunk has the executable byte-code allocated only once and have it re-used after that. It only allocates instance data (24-bytes) for each timer object, which is a 24-bytes COM object with a pointer at offset 0 pointing to the vtbl with function pointers in the pre-allocated executable byte-code chunk.

    Anyway, if built-in Timer control is used as a control array then a single Load Timer(m_lCount) call will certainly allocate more than 32 bytes of memory for all the ActiveX control infrastructure there is.

    Not sure about the performance part. It's possible that built-in Timer control is ticking faster :-))

    > I still maintain that it is better to use the timer control for my case But my colleagues insist that I replace it with api, what do you think?

    Use built-in Timer control, there is nothing wrong with it per se. Using a timer (any kind of) for detecting mouse leave events is a bit sub-optimal though IMO.

    Edit: Here is how I'm using timer thunk in a self-contained windowless user-control of mine to animate state transitions of the button control in question (not for mouse leave). This control need cooperation by the control container to detect mouse leave events, i.e. TrackMouseEvent, subclassing and WM_MOUSELEAVE are expected to be all implemented on the container form which is not very convenient (or self-containing, ooops).

    cheers,
    </wqw>

Posting Permissions

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



Featured


Click Here to Expand Forum to Full Width