VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "clsDirectTestTool" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '------------------------------------------------------------------------- 'This class provides a RunTest method to be called to run a Direct 'Instanciation model test. '------------------------------------------------------------------------- Public Sub RunTest() '------------------------------------------------------------------------- 'Purpose: Executes a loop for glNumberOfCalls each time calling ' AEWorker.Worker.DoActivity. This method actually runs ' a test according to set properties 'Assumes: All Client properties have been set. 'Effects: ' Calls CompleteTest when finished calling Worker ' [gbRunning] ' Is true during procedure ' [glFirstServiceTick] ' becomes the tick count of when the test is started ' [glLastCallbackTick] ' becomes the tick count of when the last call is made ' [glCallsMade] ' is incremented every time the Worker is called '------------------------------------------------------------------------- 'Called by tmrStartTest so that the StartTest method can release 'the calling program. Const lMAX_COUNT = 2147483647 Dim s As String 'Error message Dim sServiceID As String 'Service Request ID Dim lTicks As Long 'Tick Count Dim lEndTick As Long 'DoEvents loop until this Tick Count Dim lCallNumber As Long 'Number of calls to Worker Dim lNumberOfCalls As Long 'Test duration in number of calls Dim iDurationMode As Integer 'Test duration mode Dim lDurationTicksEnd As Long 'Tick that test should end on Dim bPostingServices As Boolean 'In main loop of procedure Dim iRetry As Integer 'Number of call reties made by error handling resume Dim vSendData As Variant 'Data to send with Service request Dim bRandomSendData As Boolean 'If true vSendData needs generated before each new request Dim sSendCommand As String 'Command string to be sent with Service Request Dim bRandomCommand As Boolean 'If true sSendCommand needs generated before each new request Dim lCallWait As Long 'Number of ticks to wait between calls Dim bRandomWait As Boolean 'If true lCallWait needs generated before each new request Dim bSendSomething As Boolean 'If true data needs passed with request Dim bReceiveSomething As Boolean 'If true data is expected back from request Dim oWorker As APEInterfaces.IWorker 'Local reference to the Worker Dim bLog As Boolean 'If true log records Dim bShow As Boolean 'If true update display On Error GoTo RunTestError 'If there is reentry by a timer click exit sub If gbRunning Then Exit Sub gbRunning = True 'Set the local variables to direct the testing Set oWorker = CreateObject("AEWorker.Worker") 'Pass configuration settings to the Worker With oWorker .SetProperties gbLogWorker, gbEarlyBindServices, gbPersistentServices, glClientID 'The Worker ID is the same as the Clients' ID in direct case If gbPreloadServices Then .LoadServiceObject IIf(gbUseDefaultService, gsSERVICE_LIB_CLASS, gsServiceCommand), gvServiceConfiguration End If End With bRandomSendData = GetTestData(bSendSomething, bReceiveSomething, vSendData) lCallWait = GetValueFromRange(gudtWaitPeriod, bRandomWait) sSendCommand = GetServiceCommand(bRandomCommand) bLog = gbLog bShow = gbShow s = LoadResString(giTEST_STARTED) If bLog Then AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False DisplayStatus s glFirstServiceTick = GetTickCount() glLastCallbackTick = glFirstServiceTick ' If 0 calls are completed, the time spent will be 0 ticks 'Test duration variables iDurationMode = giTestDurationMode If iDurationMode = giTEST_DURATION_CALLS Then lNumberOfCalls = glNumberOfCalls ElseIf iDurationMode = giTEST_DURATION_TICKS Then lDurationTicksEnd = glFirstServiceTick + glTestDurationInTicks End If bPostingServices = True KeepPostingServices: Do While Not gbStopping 'Check if new data needs generated because of randomization If bRandomSendData Then bRandomSendData = GetTestData(bSendSomething, bReceiveSomething, vSendData) If bRandomWait Then lCallWait = GetValueFromRange(gudtWaitPeriod, bRandomWait) If bRandomCommand Then sSendCommand = GetServiceCommand(bRandomCommand) 'Increment number of calls made lCallNumber = glCallsMade + 1 'Post the service to a worker 'Post a synchronous service sServiceID = glClientID & "." & lCallNumber iRetry = 0 'Display CallsMade If bShow Then With frmClient .lblCallsMade = lCallNumber .lblCallsMade.Refresh End With End If If bSendSomething Then oWorker.DoService sServiceID, sSendCommand, vSendData Else oWorker.DoService sServiceID, sSendCommand End If glLastCallbackTick = GetTickCount 'Display CallsReturned If bShow Then With frmClient .lblCallsReturned = lCallNumber .lblCallsReturned.Refresh End With End If 'If gbStopping Then Exit Do 'Go into an idle loop util the next call. If lCallWait > 0 Then lEndTick = GetTickCount + lCallWait Do While GetTickCount() < lEndTick And Not gbStopping DoEvents Loop End If glCallsMade = lCallNumber glCallsReturned = lCallNumber 'See if it is time to stop the test If iDurationMode = giTEST_DURATION_CALLS Then If lCallNumber >= lNumberOfCalls Then Exit Do ElseIf iDurationMode = giTEST_DURATION_TICKS Then If GetTickCount >= lDurationTicksEnd Then Exit Do End If Loop StopTestNow: bPostingServices = False gbRunning = False Set oWorker = Nothing If gbStopping Then 'Someone hit the stop button on the Explorer. gStopTest Exit Sub End If If bLog Then AddLogRecord gsNULL_SERVICE_ID, LoadResString(giSERVICES_POSTED), GetTickCount(), False CompleteTest Exit Sub RunTestError: Select Case Err.Number Case RPC_E_CALL_REJECTED 'Collision error, the OLE server is busy Dim il As Integer Dim ir As Integer 'First check if stopping test If gbStopping Then GoTo StopTestNow AddLogRecord gsNULL_SERVICE_ID, LoadResString(giQUEUE_SERVICE_COLLISION_RETRY), GetTickCount(), False If iRetry < giMAX_ALLOWED_RETRIES Then iRetry = iRetry + 1 ir = Int((giRETRY_WAIT_MAX - giRETRY_WAIT_MIN + 1) * Rnd + giRETRY_WAIT_MIN) For il = 0 To ir DoEvents Next il If gbStopping Then Resume Next Else Resume Else 'We reached our max retries s = LoadResString(giCOLLISION_ERROR) AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False DisplayStatus s StopOnError s Exit Sub End If Case ERR_OBJECT_VARIABLE_NOT_SET 'Worker was not successfully created s = LoadResString(giQUEUE_SERVICE_ERROR) & CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description DisplayStatus Err.Description AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False StopOnError s Exit Sub Case ERR_CANT_FIND_KEY_IN_REGISTRY 'AEInstancer.Instancer is a work around for error '-2147221166 which occurrs every time a client 'object creates an instance of a remote server, 'destroys it, registers it local, and tries to 'create a local instance. The client can not 'create an object registered locally after it created 'an instance while it was registered remotely 'until it shuts down and restarts. Therefore, 'it works to call another process to create the 'local instance and pass it back. Dim oInstancer As APEInterfaces.IInstancer Set oInstancer = CreateObject("AEInstancer.Instancer") Set oWorker = oInstancer.object("AEWorker.Worker") Set oInstancer = Nothing Resume Next Case RPC_S_UNKNOWN_AUTHN_TYPE Dim iResult As Integer 'Tried to connect to a server that does not support 'specified authentication level. Display message and 'switch to no authentication and try again s = LoadResString(giUSING_NO_AUTHENTICATION) DisplayStatus s AddLogRecord gsNULL_SERVICE_ID, s, 0, False glConnectionAuthentication = RPC_C_AUTHN_LEVEL_NONE iResult = goRegClass.SetAutoServerSettings(True, "AEWorker.Worker", , gsConnectionAddress, gsConnectionProtocol, glConnectionAuthentication) Resume Case ERR_OVER_FLOW s = CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description lCallNumber = 0 AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False Case giRPC_ERROR_ACCESSING_COLLECTION Set oWorker = Nothing s = LoadResString(giRPC_ERROR_ACCESSING_COLLECTION) DisplayStatus s AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False StopOnError s Exit Sub Case RPC_PROTOCOL_SEQUENCE_NOT_FOUND 'Most probably because of an attempt to create a Named Pipe under Win95 If frmClient.SysInfo.OSPlatform = 1 And gbConnectionNetOLE = False And gbConnectionRemote = True _ And gsConnectionProtocol = "ncacn_np" Then Set oWorker = Nothing s = LoadResString(giNO_NAMED_PIPES_UNDER_WIN95) AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False DisplayStatus s StopOnError s Exit Sub End If Case Else s = LoadResString(giQUEUE_SERVICE_ERROR) & CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description DisplayStatus Err.Description AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False If bPostingServices Then StopOnError s Exit Sub Else Resume Next End If End Select End Sub