Este codigo es especialmente para los juegos o lo que este dentro de un Do/While o similar (Juegos, o Cantroles DIbUJAdOS, o sencillamente procesos en un Do/While por decir alguno).


En un Modulo Tipo Clase:

CLSFrameLimiter.cls

 
''   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////
 
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
 
Private m_CurFrequency As Currency
Private m_HasCounter As Boolean
Private m_FrameStart As Currency
Private m_FrameEnd As Currency
Private m_CurTime As Currency
Private m_Delay As Currency
Private m_LastSecond As Long
Private m_LastSecondCount As Long
Private m_FrameCount As Long
 
Private Sub Class_Initialize()
    m_HasCounter = QueryPerformanceFrequency(m_CurFrequency)
    m_CurFrequency = m_CurFrequency * 10000
End Sub
 
Public Function GetFPS() As Long
    GetFPS = m_LastSecondCount
End Function
 
Public Sub LimitFrames(ByVal nFPS As Integer)
    If Second(Now) <> m_LastSecond Then
        m_LastSecond = Second(Now)
        m_LastSecondCount = m_FrameCount
        m_FrameCount = 0
    End If
    m_FrameCount = m_FrameCount + 1
    QueryPerformanceCounter m_FrameEnd
    '   //  m_Delay = ((1000 / nFPS) * m_CurFrequency / 10000000) - (m_FrameEnd - m_FrameStart)
    m_Delay = ((1 / nFPS) * m_CurFrequency / 10000) - (m_FrameEnd - m_FrameStart)
    Do
        DoEvents
        QueryPerformanceCounter m_CurTime
    Loop Until (m_CurTime - m_FrameEnd) >= m_Delay
 
    QueryPerformanceCounter m_FrameStart
End Sub
 

Forma de USO

 
Dim FrameLimit                      As New CLSFrameLimiter
Dim NoSalir                         as boolean
 
Private Sub Form_Click()
    NoSalir=not NoSalir
End Sub
 
Private Sub Form_Load()
    NoSalir = false
    show
    While NoSalir
        '   //  No es nesesario DoEvents, Sleep() o waitMessage() {En algun caso es usado NO?}
        Call FrameLimit.LimitFrames(40)
        caption = FrameLimit.GetFPS
    Wend
End Sub
 
 

Ejemplo Demostrativo:

Option Explicit
 
'Used to just grab framerates.
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim NoSalir                         As Boolean
Dim FrameLimit                      As New CLSFrameLimiter
 
Private Sub Form_Click()
    NoSalir = Not NoSalir
    Call PruebaFrameSecunds
End Sub
 
Private Sub PruebaFrameSecunds()
Dim lngCount                        As Long
Dim lngFPS                          As Long
Dim lngTick                         As Long
Dim okFPS                           As Long
    While NoSalir
        '   //  No es nesesario DoEvents, Sleep() o waitMessage() {En algun caso es usado NO?}
        Call FrameLimit.LimitFrames(40)
        Cls
        lngFPS = lngFPS + 1
        If lngTick < GetBetterTick Then
            okFPS = lngFPS
            lngTick = GetBetterTick + 1000
            lngFPS = 0
        End If
        Print "Frames por calculo: " & CStr(okFPS)
        Print "Frames por la Funcion: " & FrameLimit.GetFPS
    Wend
End Sub
 
Private Function GetBetterTick() As Long
    Static LastTime As Long
    If LastTime >= 0 And GetTickCount < 0 Then LastTime = GetTickCount
    If LastTime <= 0 And GetTickCount > 0 Then LastTime = GetTickCount
    GetBetterTick = GetTickCount - LastTime
End Function
 
Private Sub Form_Load()
    AutoRedraw = True
End Sub
 

Dulces Lunas!¡.

Esta bueno Black!