cambalinho – The Blog Pros

heres my timer class with a module(on a group project for create a DLL):

'Module:
Option Explicit

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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private mcolItems   As Collection

Public Sub AddTimer(ByRef pobjTimer As APITimer, ByVal plngInterval As Long)
    If mcolItems Is Nothing Then
        Set mcolItems = New Collection
    End If
    pobjTimer.ID = SetTimer(0, 0, plngInterval, AddressOf Timer_CBK)
    mcolItems.Add ObjPtr(pobjTimer), pobjTimer.ID & "K"
End Sub

Public Sub RemoveTimer(ByRef pobjTimer As APITimer)
On Error GoTo ErrHandler
    mcolItems.Remove pobjTimer.ID & "K"
    KillTimer 0, pobjTimer.ID
    pobjTimer.ID = 0
    If mcolItems.Count = 0 Then
        Set mcolItems = Nothing
    End If
    Exit Sub
ErrHandler:

End Sub

Public Sub Timer_CBK(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long)
Dim lngPointer  As Long
Dim objTimer    As APITimer
On Error GoTo ErrHandler
    lngPointer = mcolItems.Item(idEvent & "K")
    Set objTimer = PtrObj(lngPointer)
    objTimer.RaiseTimerEvent
    Set objTimer = Nothing
    Exit Sub
ErrHandler:

End Sub

Private Function PtrObj(ByVal Pointer As Long) As Object
Dim objObject   As Object
    CopyMemory objObject, Pointer, 4&
    Set PtrObj = objObject
    CopyMemory objObject, 0&, 4&
End Function

'class:
Option Explicit

Private Const CLASS_NAME As String = "APITimer"


Public Event Refresh()

Private mlngTimerID      As Long

Friend Property Let ID(ByVal plngValue As Long)
    mlngTimerID = plngValue
End Property

Friend Property Get ID() As Long
    ID = mlngTimerID
End Property

Public Sub StartTimer(ByVal Interval As Long)
    If mlngTimerID = 0 Then
        AddTimer Me, Interval
    End If
End Sub

Public Sub StopTimer()
    If mlngTimerID > 0 Then
        RemoveTimer Me
    End If
End Sub

Private Sub Class_Terminate()
    StopTimer
End Sub

Friend Sub RaiseTimerEvent()
    RaiseEvent Refresh
End Sub

after create a DLL, i'm using it on my project:

Dim GameBitmap As New vbAPITimerTools.clsImage
Dim WithEvents tmr As vbAPITimerTools.APITimer
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If (KeyCode = vbKeyEscape) Then
        FreeResources
    End If
End Sub


Private Sub Form_Load()
    Set tmr = New vbAPITimerTools.APITimer

    blnGameLoop = True
    Me.Show
    PreencherMatriz Level1, _
            ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, _
            ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbBlack, _
            ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, _
            ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, _
            ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, _
            ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, _
            ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, _
            ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbBlack, _
            ColorConstants.vbBlack, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbWhite, ColorConstants.vbBlack, _
            ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack, ColorConstants.vbBlack
    FPS = 0
    FramesCount = 0


    Set GameBitmap = New vbAPITimerTools.clsImage
    GameBitmap.NewImage 32 * 10, 32 * 10
    FillWall1 = GameBitmap.CreateBrush(vbBlack)
    FillEmpty = GameBitmap.CreateBrush(vbWhite)
    DrawMap GameBitmap.MemoryHDC, Level1


    tmr.StartTimer 1000
    While (blnGameLoop)
        GameBitmap.Draw Me.hdc
        FramesCount = FramesCount + 1
        DoEvents
    Wend
End Sub

Private Sub tmr_Refresh()
    On Error Resume Next
    FPS = FramesCount
    Me.Caption = "FPS: " & CStr(FPS)
    FramesCount = 0
End Sub

Private Sub Form_Terminate()
    'FreeResources
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'FreeResources

End Sub

Private Sub FreeResources()
    blnGameLoop = False

    GameBitmap.DestroyPenBrush FillWall1
    GameBitmap.DestroyPenBrush FillEmpty

    tmr.StopTimer
    Set GameBitmap = Nothing
    Set tmr = Nothing
    End
End Sub

when i press Escape key, the program terminate... but the project too.. seems that i have a memory leak and i don't know why :(
on Group project i test the timer without problems... what i miss?
PS: i tested without the timer instance and no problems...

Author: cambalinho

VB6: how avoid these memory leak on API timer?