[SRC] cFrogContest.cls [by Mr. Frog ©]

[Psyke1]

Hola chicos, aqui os dejo uno de mis últimos inventos: cFrogContest.cls.
Consiste en una clase cuya finalidad es facilitar los test realizados en los retos que últimamente están tan de moda en la sección.

Consta de las siguientes carácterísticas:

• Únicamente una clase, no depende de ningún módulo ni nada más
• Muestra las funciones con llamadas erroneas
• Muestra las funciones con resultados erroneos
• Consta si fue compilado o no para hacer los test
• Las funciones deben ser públicas
• Basado en CTiming (con variantes)

Bueno aqui os dejo la clase:

Código (vb) [Seleccionar] Expandir

Option Explicit
Option Base 0
'======================================================================
' º Class      : cFrogContest.cls
' º Version    : 1.1
' º Author     : Mr.Frog ©
' º Country    : Spain
' º Mail       : vbpsyke1@mixmail.com
' º Date       : 03/02/2011
' º Last mod   : 12/02/2011
' º Twitter    : http://twitter.com/#!/PsYkE1
' º Dedicated  : Karcrack, BlackZer0x & Raul338
' º References :
'       http://www.xbeat.net/vbspeed/download/CTiming.zip
'       http://www.devx.com/tips/Tip/15422
' º Recommended Websites :
'       http://foro.h-sec.org
'       http://visual-coders.com.ar
'       http://InfrAngeluX.Sytes.Net
'======================================================================

'@oleaut32.dll
Private Declare Function SafeArrayGetDim Lib "oleaut32" (ByRef vArray() As Any) As Long
'@shlwapi.dll
Private Declare Function PathIsDirectoryA Lib "shlwapi" (ByVal pszPath As String) As Long
'@kernel32.dll
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
'@shell32.dll
Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pidl As Long, ByVal szPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long

'// Types
Private Type TEST_FUNCTION
   Name        As String
   Duration    As Double
End Type

Private Type LARGE_INTEGER
   LowPart     As Long
   HighPart    As Long
End Type

'// Constants
Private Const MAX_PATH                              As Long = &H100
Private Const SW_MAXIMIZE                           As Long = &H3
Private Const OVERHEAD_TEST                         As Long = &HC8
Private Const CSIDL_DESKTOP                         As Long = &H0

'// Variables
Private myFunction()                                As TEST_FUNCTION
Private dblOverHead                                 As Double
Private curTimeFreq                                 As Currency

Private oTLI                                        As Object
Private myObj                                       As Object

Private bolRet                                      As Boolean
Private bolArgs                                     As Boolean
Private bolError                                    As Boolean
Private bolReplace                                  As Boolean
Private bolNotCompiled                              As Boolean

Private lngUBRet                                    As Long
Private lngUBound                                   As Long
Private lngNumberLoops                              As Long

Private strLine                                     As String
Private strLine2                                    As String
Private strArguments                                As String
Private strFunction()                               As String
Private strDirSaveTest                              As String
Private strContestName                              As String
Private srtExplanation                              As String

Private varRet                                      As Variant
Private varResult                                   As Variant
Private varRevArgs()                                As Variant

Private liStop                                      As LARGE_INTEGER
Private liStart                                     As LARGE_INTEGER
Private liFrequency                                 As LARGE_INTEGER

'                                         ~~~~~~~> Public Properties <~~~~~~~

Friend Property Let ContestName(ByRef ContestName As String)
   strContestName = ContestName
End Property

Friend Property Let Explanation(ByRef Explanation As String)
   srtExplanation = Explanation
End Property

Friend Sub SetObject(OneObject As Object)
   Set myObj = OneObject
End Sub

Friend Sub Functions(ByRef Functions As String, Optional ByRef Delimiter As String = ",")
'------------------------------------------------
' * Important : All the functions must be public.
'------------------------------------------------
   strFunction = Split(Functions, Delimiter)
   lngUBound = UBound(strFunction)
End Sub

Friend Sub Arguments(ParamArray Arguments() As Variant)
Dim lngTotalItems                                   As Long
Dim Q                                               As Long

   If Not IsMissing(Arguments) Then
       lngTotalItems = UBound(Arguments)
       strArguments = Join$(Arguments, ", ")

       ReDim varRevArgs(lngTotalItems) As Variant
       For Q = 0 To lngTotalItems
           varRevArgs(Q) = Arguments(lngTotalItems - Q)
       Next Q

       bolArgs = True
   End If
End Sub

Friend Property Let ReplaceFile(ByVal ReplaceIt As Boolean)
   bolReplace = ReplaceIt
End Property

Friend Property Let NumberOfLoops(ByVal Times As Long)
   lngNumberLoops = Times
End Property

Friend Property Let Result(ByRef Result As Variant)
'---------------------------------------------------------------------
' * Important : It doesn't support multidimensional arrays or objects.
'---------------------------------------------------------------------
Dim lngLBound                                       As Long
Dim Q                                               As Long

   Select Case VarType(Result)
       Case vbDataObject, vbEmpty, vbNull, vbObject, vbUserDefinedType
           Exit Property
       Case Else
           If IsArray(Result) Then
               lngUBRet = UBound(Result)

               If VarType(Result) = vbArray + vbString Then
                   varResult = Join$(Result)
               Else
                   lngLBound = LBound(Result)
                   If lngLBound Then
                       lngUBRet = lngUBRet - lngLBound
                       ReDim varResult(lngUBRet) As Variant
                       
                       For Q = 0 To lngUBRet
                           varResult(Q) = Result(Q + lngLBound)
                       Next Q
                   Else
                       varResult = Result
                   End If
               End If
           Else
               varResult = Result
           End If
   End Select

   bolRet = True
End Property

Friend Property Let SaveDirectory(ByRef DirPath As String)
   If PathIsDirectoryA(DirPath) Then
       strDirSaveTest = DirPath
   Else
       strDirSaveTest = GetDesktopPath
   End If

   If Not (Right$(strDirSaveTest, 1) = "\") Then
       strDirSaveTest = strDirSaveTest & "\"
   End If
End Property

'                                   ~~~~~~~> Public Functions & Procedures <~~~~~~~

Friend Sub TestIt()
Dim dblTmpDuration                                  As Double
Dim colError                                        As New Collection
Dim colErrCall                                      As New Collection
Dim strFName                                        As String
Dim bolWrong                                        As Boolean
Dim ff                                              As Integer
Dim Q                                               As Long
Dim C                                               As Long

   If SafeArrayGetDim(strFunction) And Not (myObj Is Nothing) Then
       If LenB(strContestName) = 0 Then strContestName = "Test"
       If LenB(srtExplanation) = 0 Then srtExplanation = "-"
       If lngNumberLoops < 1 Then lngNumberLoops = 1

       For Q = 0 To lngUBound
           strFName = strFunction(Q)

           ResetTimer
           varRet = CallByNameEx(strFName)
           dblTmpDuration = GetTiming

           If bolRet Then
               bolWrong = IsWrongResult
           End If

           If bolWrong Or bolError Then
               If bolError Or (bolWrong And bolError) Then
                   bolError = False
                   colErrCall.Add strFName
                   Debug.Print "Error Call :", strFName
               ElseIf bolWrong Then
                   colError.Add strFName
                   Debug.Print "Error result :", strFName
               End If

               lngUBound = lngUBound - 1
               If lngUBound = -1 Then GoTo JumpSpeedTest
           Else
               ReDim Preserve myFunction(C) As TEST_FUNCTION

               With myFunction(C)
                   .Name = strFName
                   .Duration = dblTmpDuration
               End With

               C = C + 1
           End If
       Next Q

       If lngNumberLoops > 1 Then
           For Q = 0 To lngUBound
               With myFunction(Q)
                   ResetTimer
                   For C = 2 To lngNumberLoops
                       CallByNameEx .Name
                   Next C
                   .Duration = GetTiming + .Duration
               End With
           Next Q
       End If

       Call BubbleSort

JumpSpeedTest:

       strDirSaveTest = Left$(strDirSaveTest, InStrRev(strDirSaveTest, "\"))
       strDirSaveTest = strDirSaveTest & strContestName & ".txt"
       ff = FreeFile

       If bolReplace Then
           Open strDirSaveTest For Output As #ff
       Else
           Open strDirSaveTest For Append As #ff
       End If

           Print #ff, strLine
           Print #ff, "º Contest Name : "; strContestName
           Print #ff, "º Explanation  : "; srtExplanation
           Print #ff, "º Arguments    : "; strArguments
           Print #ff, "º Loops        : "; CStr(lngNumberLoops)
           Print #ff, "º Date & Hour  : "; Date$; " <-> "; Time$
           Print #ff, strLine

           If lngUBound > -1 Then
               Print #ff, "Results "; IIf(bolNotCompiled, "[not ", "["); "compiled] :"
               Print #ff, strLine2
           
               For Q = 0 To lngUBound
                   With myFunction(Q)
                       Print #ff, CStr(Q + 1); ".- "; .Name, , , "-> "; Format$(.Duration * 1000, "#0.000000"); " msec"
                   End With
               Next Q
           End If

           With colErrCall
               If .Count Then
                   Print #ff, strLine
                   Print #ff, "º The following calls are wrong :"
                   Print #ff, strLine2
                   
                   For Q = 1 To .Count
                       Print #ff, CStr(Q); ".- "; .Item(Q)
                   Next Q
               End If
           End With

           With colError
               If bolRet And .Count Then
                   Print #ff, strLine
                   Print #ff, "º The following functions returns incorrect results :"
                   Print #ff, strLine2
                   
                   For Q = 1 To .Count
                       Print #ff, CStr(Q); ".- "; .Item(Q)
                   Next Q
               End If
           End With

           Print #ff, strLine
           Print #ff, ">>> Test made by cFrogContest.cls <-> Visit foro.elhacker.net <<<"
           Print #ff, strLine; vbCrLf
       Close #ff
   End If
End Sub

Friend Function ShowTest() As Long
   ShowTest = ShellExecute(0, "Open", strDirSaveTest, vbNullString, vbNullString, SW_MAXIMIZE)
End Function

'                                 ~~~~~~~> Private Functions & Procedures <~~~~~~~

Private Function CallByNameEx(ByRef strProcName As String) As Variant
Dim ProcID                                          As Long

   On Error GoTo Error_
   ProcID = oTLI.InvokeID(myObj, strProcName)
   If bolArgs Then
       CallByNameEx = oTLI.InvokeHookArray(myObj, ProcID, VbMethod, varRevArgs)
   Else
       CallByNameEx = oTLI.InvokeHook(myObj, ProcID, VbMethod)
   End If
Exit Function

Error_:
   bolError = True
End Function

Private Function IsWrongResult() As Boolean
Dim lngLBound                                       As Long
Dim Q                                               As Long

   If VarType(varRet) And vbArray Then
       lngLBound = LBound(varRet)
       If UBound(varRet) - lngLBound = lngUBRet Then
           If VarType(varRet) = vbArray + vbString Then
               IsWrongResult = (varResult = Join$(varRet))
           Else
               For Q = 0 To lngUBRet
                   IsWrongResult = (varRet(Q + lngLBound) = varResult(Q))
                   If IsWrongResult Then Exit Function
               Next Q
           End If
       End If
   Else
       IsWrongResult = (varResult = varRet)
   End If

   IsWrongResult = Not IsWrongResult
End Function

Private Sub BubbleSort()
Dim SwapItem                                        As TEST_FUNCTION
Dim lngLimit                                        As Long
Dim Q                                               As Long
Dim C                                               As Long

   lngLimit = lngUBound - 1
   For Q = 0 To lngLimit
       For C = 0 To lngLimit
           If myFunction(C).Duration > myFunction(C + 1).Duration Then
               SwapItem = myFunction(C)
               myFunction(C) = myFunction(C + 1)
               myFunction(C + 1) = SwapItem
           End If
       Next C
   Next Q
End Sub

Private Function GetDesktopPath() As String
Dim lPidl                                           As Long

   GetDesktopPath = String$(MAX_PATH, vbNullChar)
   SHGetSpecialFolderLocation &H0, CSIDL_DESKTOP, lPidl
   SHGetPathFromIDListA lPidl, GetDesktopPath
   GetDesktopPath = Left$(GetDesktopPath, InStrB(GetDesktopPath, vbNullChar) \ 2)
End Function

Private Sub ResetTimer()
   QueryPerformanceCounter liStart
End Sub

Private Function GetTiming() As Double
   QueryPerformanceCounter liStop
   GetTiming = (LrgIntToCur(liStop) - LrgIntToCur(liStart) - dblOverHead) / curTimeFreq
End Function

Private Function LrgIntToCur(liInput As LARGE_INTEGER) As Currency
   RtlMoveMemory LrgIntToCur, liInput, LenB(liInput)
End Function

Private Sub Class_Initialize()
Dim Q                                               As Long

   bolNotCompiled = (App.LogMode = 0)
   If QueryPerformanceFrequency(liFrequency) = 0 Then
       MsgBox "This PC doesn't support high-res timers", vbCritical, "Fatal Error"
       End
   ElseIf bolNotCompiled Then
       MsgBox "Compile it to get real results!", vbCritical, "Advice"
   End If

   ResetTimer
   For Q = 1 To OVERHEAD_TEST
       QueryPerformanceCounter liStop
   Next Q
   dblOverHead = (LrgIntToCur(liStop) - LrgIntToCur(liStart)) / OVERHEAD_TEST

   Set oTLI = CreateObject("TLI.TLIApplication")
   strLine = String$(80, "=")
   strLine2 = String$(80, "~")
   curTimeFreq = LrgIntToCur(liFrequency)

   Debug.Print ">>> Class cFrogContest.cls initiated at " & Time$ & " <<<"
End Sub

Descargar cFrogContest.cls

Aqui os dejo un ejemplo de uso, usando todas las propiedades y funciones:

Código (vb) [Seleccionar] Expandir

Option Explicit

'@kernel32
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private cFC                     As New cFrogContest '// Class declaration.

'~~~~~~~> Functions to test.
Public Function VerySlow(ByVal lngArg1 As Long, ByVal strArg2 As String) As Long
   Sleep 4
   VerySlow = 2
End Function

Public Function Slow(ByVal lngArg1 As Long, ByVal strArg2 As String) As Long
   Sleep 2
   Slow = 2
End Function

Public Function Quick(ByVal lngArg1 As Long, ByVal strArg2 As String) As Long
   Sleep 1
   Quick = 2
End Function

Public Function VeryQuick(ByVal lngArg1 As Long, ByVal strArg2 As String) As Long
   VeryQuick = 3                                   '// I put a different result on purpose. xP
End Function

'~~~~~~~> Example of use.
Private Sub Form_Load()
   With cFC
       .ContestName = "Test1"                      '// The constest name.
       .Explanation = "It's only a simple test..." '// Little explanation.
       .SaveDirectory = "c:\"                      '// Directory where you saved the test.
       .ReplaceFile = False                        '// To overwrite the file.
       .Functions "VerySlow,VeryQuick,Slow,Quick"  '// Name of the functions.
       .Arguments 20, "Long life to Frogs!"        '// Arguments of functions (must be the same in all functions).
       .NumberOfLoops = 100                        '// Number of Loop to call them.
       .Result = 2                                 '// This result should give functions.
       .SetObject Me                               '// Object (needed to make the calls).
       .TestIt                                     '// Execute the test and save it.
       .ShowTest                                   '// Shows the txt file.
   End With

   End                                             '// Exit.
End Sub

Este es el resultado que aparece en el txt:

Código [Seleccionar] Expandir

================================================================================
º Contest Name : Test1
º Explanation  : It's only a simple test...
º Arguments    : 20, Long life to Frogs!
º Loops        : 100
º Date & Hour  : 02-12-2011 <-> 22:25:05
================================================================================
Results [not compiled] :
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.- Quick                                 -> 193,846610 msec
2.- Slow                                  -> 292,967082 msec
3.- VerySlow                              -> 490,423567 msec
================================================================================
º The following functions returns incorrect results :
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.- VeryQuick
================================================================================
>>> Test made by cFrogContest.cls <-> Visit foro.elhacker.net <<<
================================================================================

También se podría hacer esto:

Código (vb) [Seleccionar] Expandir


'...
'~~~~~~~> Example of use.
Private Sub Form_Load()
   With cFC
       .ContestName = "Test1"                      '// The constest name.
       .Explanation = "It's only a simple test..." '// Little explanation.
       .SaveDirectory = "c:\"                      '// Directory where you saved the test.
       .ReplaceFile = False                        '// To overwrite the file.
       .Functions "VerySlow,VeryQuick,Slow,Quick"  '// Name of the functions.
       .Arguments 20, "Long life to Frogs!"        '// Arguments of functions (must be the same in all functions).
       .NumberOfLoops = 100                        '// Number of Loop to call them.
       .Result = 2                                 '// This result should give functions.
       .SetObject Me                               '// Object (needed to make the calls).
       .TestIt                                     '// Execute the test and save it.
       
       .Explanation = "Second test"
       .Result = 3
       .Arguments 34, "It works good"
       .ShowTest                                   '// Shows the txt file.
   End With

   End                                             '// Exit.
End Sub

Así podemos hacer varios test de una sola vez...

Esto es todo, espero que os haya gustado.
Estoy abierto a nuevas ideas y recomendaciones.

DoEvents!

[ntaryl]

Amazing Bro   
+2  from me 

[79137913]

HOLA!!!

Esta genial el cls, siempre es muy aburrido hacer testers.

Unica observacion es que no me gusta como devuelve los resultados (el dibujito , los cuadros) habria que hacerlo un poco mas lindo.

GRACIAS POR LEER!!!

[raul338]

Linda implementacion del TypeLibApplication, Aunque yo modificaría y pondría a ordenar con QuickSort en lugar de BubbleSort

A ver si lo usamos en los próximos retos

[Psyke1]

Gracias
Raul, tengo explicación para eso, uso BubbleSort porque el tamaño del array a ordenar es ridículo (10 funciones, 20 como mucho... )
Entonces, de este modo no se nota tanta diferencia entre usar QuickSort o BubbleSort.

DoEvents!

[BlackZeroX]

.
Por fin lo liberas.

Aun que el punto de que se necesita al menos un por form en el proyecto , eso no es del todo cierto se puede tener trantilamente un sub main() que cargue una clase y la misma llame a esta clase para su implementación.

* Las propiedades deberias bloquearlas si es que ya se llamo a el proceso TestIt()
* Me gusto la simplificacion de la funcio CallByNameEx
* Antes de hacer los test deberias hacer una comrovacion de llamar a las funciones si es que existen, y si cumplen la cantidad de parametros minimos, es decir Antes de hacer los test  esto para evitar hacer llamadas innesesarias.


P.D.: Te falto la referencia de TLI.TLIApplication

Temibles Lunas!¡.

[Psyke1]

.
Por fin lo liberas.

Aun que el punto de que se necesita al menos un por form en el proyecto , eso no es del todo cierto se puede tener trantilamente un sub main() que cargue una clase y la misma llame a esta clase para su implementación.

* Las propiedades deberias bloquearlas si es que ya se llamo a el proceso TestIt()
* Me gusto la simplificacion de la funcio CallByNameEx
* Antes de hacer los test deberias hacer una comrovacion de llamar a las funciones si es que existen, y si cumplen la cantidad de parametros minimos, es decir Antes de hacer los test  esto para evitar hacer llamadas innesesarias.


P.D.: Te falto la referencia de TLI.TLIApplication

Temibles Lunas!¡.

1.-Puse lo del Form porque pensé que sería más simple y cómodo, tambien puedes hacer una clase vacía como tú dices.
2.-Para bloquearlas pondré un boolean
4.-Ook, haré eso para evitar dar vueltas sin motivo.
5.-Cierto, no lo puse porque modifiqué mucho, pero tienes razón, lo agregaré.

Muchas gracias por el comentario constructivo Black!
En estos dias mejoraré la clase

DoEvents!

[Edu]

Bueno la proxima version podria ser que vs escribas las funciones en un textbox y con un boton diga la velocidad xD
Reto para ustedes, si es q son buenos programadores... xD Quiero ver si lo logran hacer..

[Psyke1]

Bueno la proxima version podria ser que vs escribas las funciones en un textbox y con un boton diga la velocidad xD
Reto para ustedes, si es q son buenos programadores... xD Quiero ver si lo logran hacer..

¿Qué más da escribirlas en un Textbox que en el proyecto?, no le veo la finalidad ha hacerlo de ese modo.
En estos días arreglaré lo que me han comentado.

DoEvents!

[BlackZeroX]

.
@XXX-ZERO-XXX

Es demasiado trivial si sabes para que es esta clase y la forma de usar la misma.

Dulces Lunas!¡.