• Ú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)

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

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

================================================================================
º 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 <<<
================================================================================

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