* [ Source ] CLSFrameLimiter.cls (Frecuencia)

[BlackZeroX]

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

Código (vb) [Seleccionar] Expandir



''   /////////////////////////////////////////////////////////////
'   // 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

Código (vb) [Seleccionar] Expandir



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:

Código (vb) [Seleccionar] Expandir


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

[MCKSys Argentina]

Muy Bueno!!

Gracias por compartir 

[ssccaann43 ©]

Esta bueno Black!