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