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
Mostrar Mensajes
