Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Timer Loop (Messagepump with Interval function call)

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Timer Loop (Messagepump with Interval function call)

    Code:
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' An alternative "timer" loop  by Peter Scheutz Feb. 2001.          '
    '                                                                   '                                                              '
    ' Gives good timing, even with timeGetTime.                         '
    ' Goes below the limits of the normal SetTimer() timer.             '
    ' No buildup of events, if your processing takes too long.          '
    ' Uses PerformanceCounter if present, otherwise uses timeGetTime(). '
    ' Simple to use, and no hanging timer thread if you app crashes.    '
                                                                        '
    ' Released as Public domain.                                        '
    '                                                                   '
    '                                                                   '
    ' Inspired by  MSDN:                                                '
    ' Moving Your Game to Windows, Part I: Tools, Game Loop,            '
    ' Keyboard Input, And Timing                                        '
    '                                                                   '
    ' Peter Donnelly                                                    '
    ' Microsoft Developer Network Technology Group                      '
    ' September 26, 1996                                                '
    '                                                                   '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    
    $Compile Exe
    Option Explicit
    $Include "WIN32API.INC"
    
    
    ' This Union is for converting a LARGE_INTEGER to a Quad
    ' I hope I'm doing that right. You might want to check...
    Union QuadThing
      Whole As Quad
      Part  As LARGE_INTEGER
    End Union
    
    
    Global mainExit As Long
    
    Sub MyTimerProc(ByVal hWnd As Long, framesPerSec As Double)
       SetWindowText hWnd,"Frames per sec: " & Format$(framesPerSec, "###.##")
       ' you can provoke a paint event here by using Invalidaterect()
    End Sub
    
    
    Function WinMain( ByVal hInstance As Long, _
        ByVal hPrevInstance As Long, _
        lpCmdLine As Asciiz Ptr, _
        ByVal iCmdShow As Long ) As Long
    
        Local Msg As tagMsg
        Local wndclass As WndClassEx
        Local szClassName As Asciiz * 80
        Local hWnd As Long
    
        Local nowtime As Quad
        Local oldtime As Quad
        Local quadFreq As QuadThing
        Local quadNowTime As QuadThing
        Local quadOldTime As QuadThing
    
        Local TicksPerFrame As Quad
        Local ticsPerSec As Quad
        Local usePerformanceCounter As Long
    
    
        szClassName = "MYCLASS"
        wndclass.cbSize = SizeOf( WndClass )
        wndclass.style = %CS_HREDRAW Or %CS_VREDRAW '
        wndclass.lpfnWndProc = CodePtr( WndProc )
        wndclass.cbClsExtra = 0
        wndclass.cbWndExtra = 0
        wndclass.hInstance = hInstance
        wndclass.hIcon = LoadIcon( hInstance, "PROGRAM" )
        wndclass.hCursor = LoadCursor( %NULL, ByVal %IDC_ARROW )
        wndclass.hbrBackground = GetStockObject( %LTGRAY_BRUSH )
        wndclass.lpszMenuName = %NULL
        wndclass.lpszClassName = VarPtr( szClassName )
        wndclass.hIconSm = %Null
        RegisterClassEx wndclass
    
        hWnd = CreateWindow( szClassName, _
        "Timer loop", _
        %WS_CAPTION Or %WS_SYSMENU, _
        100, _
        200, _
        400, _
        300, _
        %HWND_DESKTOP, _
        %NULL, _
        hInstance, _
        ByVal %NULL )
    
    
        QueryPerformanceFrequency  quadFreq.Part
    
        'quadFreq.whole=0 ' UnREM to use  timeGetTime
    
        If quadFreq.whole<>0 Then   'is PerformanceCounter present?
           usePerformanceCounter=%True
        Else
           quadFreq.whole=1000 ' for use with timeGetTime
           ' Msgbox "PerformanceCounter not present - using timeGetTime"
        End If
    
        %MS_PER_FRAME = 100' 33.33333333 ' 1 5 15  20  33  100 - try different values!
    
        TicksPerFrame = (quadFreq.whole/1000)* %MS_PER_FRAME
    
        mainExit = %FALSE
    
        ShowWindow hWnd, %SW_SHOW
        UpdateWindow hWnd
    
        ' This could be divided into two separate loops for  efficiency
        ' If you only want to use timeGetTime, Longs could be used instead.
    
    
        Do Until mainExit = %TRUE
            If PeekMessage( Msg, %NULL, 0, 0, %PM_NOREMOVE ) Then
                If getMessage( Msg, %NULL, 0, 0 ) = %FALSE Then
                    mainExit = %TRUE
                Else
                    TranslateMessage Msg
                    DispatchMessage Msg
                End If
            End If
    
    
            If usePerformanceCounter=%True Then
                QueryPerformanceCounter quadNowTime.part
                nowtime=quadNowTime.whole
            Else
                nowtime = timeGetTime()
            End If
    
            If nowtime > = oldtime + TicksPerFrame Then
               
                If mainExit = %FALSE Then
                    myTimerProc hWnd , quadFreq.whole/(nowtime-oldtime)
                End If
    
                oldtime = nowtime
                
            End If
        Loop
    
        Function = Msg.wParam
    
    End Function
    
    
    Function WndProc( ByVal hWnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long ) Export As Long
    
        Local ps As PAINTSTRUCT
        Local hDC As Long
        
        Select Case wMsg
    
            Case %WM_SYSCOMMAND
                If wParam = %SC_CLOSE Then
                    mainExit = %TRUE
                End If
    
            Case %WM_PAINT
                If mainExit = %False Then
                    hDC = BeginPaint( hWnd, ps )
                    ' do painting here
                    EndPaint hWnd, ps
    
                End If
            Case %WM_CLOSE
                mainExit = %TRUE
            Case %WM_DESTROY
    
                PostQuitMessage 0
                Function = 0
                Exit Function
    
        End Select
    
        Function = DefWindowProc( hWnd, wMsg, wParam, lParam )
    
    End Function
    ------------------




    [This message has been edited by Peter Scheutz (edited February 03, 2001).]
    Best Regards
    Peter Scheutz
Working...
X