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. :rolleyes: :xD
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
- Se necesita al menos un Form en el proyecto
- Las funciones deben ser públicas
- Basado en CTiming (con variantes)
Bueno aqui os dejo la clase, aún se encuentra en fase Beta.
Option Explicit
Option Base 0
'======================================================================
' º Class : cFrogContest.cls
' º Version : 1.0
' º Author : Mr.Frog ©
' º Country : Spain
' º Mail : vbpsyke1@mixmail.com
' º Date : 03/02/2011
' º Twitter : http://twitter.com/#!/PsYkE1
' º Dedicated : Karcrack, BlackZer0x & Raul388
' º Reference : http://www.xbeat.net/vbspeed/download/CTiming.zip
' º Important : Your proyect must have at least one Form.
' º Recommended Websites :
' http://foro.h-sec.org
' http://visual-coders.com.ar
' http://InfrAngeluX.Sytes.Net
'======================================================================
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function ShellExecute Lib "shell32.dll" 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 SafeArrayGetDim Lib "oleaut32.dll" (ByRef vArray As Variant) As Long 'Argument mod
Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) 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
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
Private Type TEST_FUNCTION
Name As String
Duration As Double
End Type
Private Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Private Const MAX_PATH As Long = &H100
Private Const SW_MAXIMIZE As Long = &H3
Private Const OVERHEAD_TEST As Long = &H64
Private Const CSIDL_DESKTOP As Long = &H0
Private myFunction() As TEST_FUNCTION
Private dblOverHead As Double
Private curTimeFreq As Currency
Private oTLI As Object
Private myObj As Object
Private colErrCall As Collection
Private bolRet As Boolean
Private bolArgs 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 Functions(ByRef Functions As String, Optional ByRef Delimiter As String = ",")
'-------------------------------------------
' º Note : 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)
'----------------------------------------------------------------
' º Note : 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 VarType(Result) And vbArray Then
If IsArrayInitialited(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
End If
Else
varResult = Result
End If
End Select
bolRet = True
End Property
Friend Property Let SaveDirectory(ByRef DirPath As String)
If PathIsDirectory(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 colError As New Collection
Dim ff As Integer
Dim Q As Long
Dim C As Long
If IsArrayInitialited(strFunction) Then
If (LenB(strContestName)) = 0 Then strContestName = "Test"
If (LenB(srtExplanation)) = 0 Then srtExplanation = "-"
If lngNumberLoops <= 0 Then lngNumberLoops = 1
ReDim myFunction(lngUBound) As TEST_FUNCTION
ReDim dblTimeResults(1 To lngNumberLoops) As Double
Set colErrCall = New Collection
For Q = 0 To lngUBound
With myFunction(Q)
.Name = strFunction(Q)
ResetTimer
For C = 1 To lngNumberLoops
varRet = CallByNameEx(.Name)
Next C
.Duration = GetTiming
If bolRet Then
If IsWrongResult Then
colError.Add .Name
End If
End If
End With
Next Q
Call BubbleSort
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
Print #ff, "Results "; IIf(bolNotCompiled, "[not compiled] ", vbNullString); ":"
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
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 return 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
Set colErrCall = Nothing
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_:
PrintError strProcName
End Function
Private Sub PrintError(ByRef strError As String)
On Error GoTo Exit_:
colErrCall.Add strError, strError
Debug.Print "Error CallByNameEx ->"; strError
Exit_:
End Sub
Private Function IsWrongResult() As Boolean
Dim lngLB As Long
Dim Q As Long
If VarType(varRet) And vbArray Then
lngLB = LBound(varRet)
If UBound(varRet) - lngLB = lngUBRet Then
If VarType(varRet) = vbArray + vbString Then
IsWrongResult = Not (varResult = Join$(varRet))
Else
For Q = 0 To lngUBRet
IsWrongResult = Not (varRet(Q + lngLB) = varResult(Q))
If IsWrongResult Then Exit Function
Next Q
End If
End If
Else
IsWrongResult = Not (varResult = varRet)
End If
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 IsArrayInitialited(ByRef vArr As Variant) As Boolean
IsArrayInitialited = SafeArrayGetDim(vArr)
End Function
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 Forms(0) Is Nothing Then
MsgBox "The proyect must have a Form!", 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 myObj = Forms(0)
Set oTLI = CreateObject("TLI.TLIApplication")
strLine = String$(80, "="): strLine2 = String$(80, "-")
curTimeFreq = LrgIntToCur(liFrequency)
Debug.Print ">>> Class cFrogContest.cls initiated at " & Time$ & " <<<"
End SubAqui os dejo un
ejemplo de uso, usando todas las propiedades y funciones:
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private C As New cFrogContest '// Class declaration
Function VerySlow(a As Long, b As Long) As Long
VerySlow = 2
Sleep 4
End Function
Function Slow(a As Long, b As Long) As Long
Slow = 2
Sleep 2
End Function
Function Quick(a As Long, b As Long) As Long
Quick = 2
Sleep 1
End Function
Function VeryQuick(a As Long, b As Long) As Long
VeryQuick = 3 '// I put a different result (on purpose)
End Function
Private Sub Form_Load()
With C
.ContestName = "Test1" '// The Constest Name
.SaveDirectory = "c:\" '// Directory where you saved the test
.Explanation = "It's only a simple test..." '// Little explanation
.Arguments 20, 300 '// Arguments of functions (must be the same in all)
.Functions "VerySlow,VeryQuick,Slow,Quick" '// Name of the funcrions
.ReplaceFile = True '// To overwrite the file
.Result = 2 '// This result should give functions
.NumberOfLoops = 100 '// Number of Loop to call them
.TestIt '// Execute the test and save it
.ShowTest '// Shows the txt file
End With
End Sub
Private Sub Form_Click()
Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set C = Nothing
End SubEste es el resultado que aparece en el txt:
================================================================================
º Contest Name : Test1
º Explanation : It's only a simple test...
º Arguments : 20, 300
º Loops : 100
º Date & Hour : 02-07-2011 <-> 17:02:40
================================================================================
Results :
--------------------------------------------------------------------------------
1.- VeryQuick ------> 0,689758 msec
2.- Quick ------> 195,314236 msec
3.- Slow ------> 296,163765 msec
4.- VerySlow ------> 487,992129 msec
================================================================================
º The following functions return incorrect results :
--------------------------------------------------------------------------------
1.- VeryQuick
================================================================================
>>> Test made by cFrogContest.cls <-> Visit foro.elhacker.net <<<
================================================================================Esto es todo, espero que os haya gustado.
Estoy abierto a nuevas ideas y recomendaciones.
DoEvents!
