VB6: how avoid these memory leak on API timer?

[cambalinho]

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...

[cambalinho]

i did a simple mistake:

Set GameBitmap = Nothing

instead:

If Not GameBitmap Is Nothing Then
        Set GameBitmap = Nothing
    End If

what event is used when i press the 'stop' button on IDE?
yes is give me a memory leak :(

seems that resolve for sometimes and not forever :(

[cambalinho]

1 - yes i can't assign an object\instance to nothing without test it 1st:

Dim WithEvents tmr As vbAPITimerTools.APITimer 'create a vbAPITimerTools.APITimer instance with an event
Set tmr = New vbAPITimerTools.APITimer 'initializate the instance

If Not tmr Is Nothing Then
        tmr.StopTimer
        Set tmr = Nothing
    End If

    ' free\destroy Brush object:
    ' i used the 'DestroyPenBrush()', but it's the 'DeleteObject()':
    If (FillWall1 <> 0) Then GameBitmap.DestroyPenBrush FillWall1
    If (FillEmpty <> 0) Then GameBitmap.DestroyPenBrush FillEmpty

2 - i can't use 'Unload()' with QueryUnload(), with 'UnloadMode'... just use the 'Unload()' is the best.... seems they aren't good with infinite loops... maybe i did more errors, but, for now, i don't get leak memory problems ;)

3 - don't use the 'stop' button, from IDE, before clear resources!!!! the form have an event for i test if the object was destroyed(speaking about the 'stop' button from IDE)?
thanks for all to all

[rproffitt]

I have yet to read the issue of leaks were entirely plugged in VB6. Example at https://forum.codejock.com/topic7921.html notes an area that appears to be "yup, it does that" in reference to MFC 6.0 CString implementation.

Given this is VB6 I don't expect any fix. At worst you'll have to restart the app.

[rproffitt]

Finding memory leaks in VB6 should be easy. That's one old leaky system. Fixing them is hard to impossible. Reference the link I supplied.