vwemirror/firestorm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial full mirror of c:\VWE (source + assets + toolchain + outputs) via Git LFS

Browse Source 
Complete disaster-recovery snapshot: engine/game source, game data assets,
VC6 toolchain + DX SDKs, build outputs, deployed game, and _UNUSED archive.
Large binaries in Git LFS; text preserved byte-for-byte (core.autocrlf=false,
no eol attributes). See RECOVERY.md for the one-clone rebuild procedure.
This commit is contained in:
Cyd
2026-06-24 21:28:16 -05:00
commit 2b8ca921cb
66341 changed files with 7923174 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/AEQUEUE.RC
+52
View File
@@ -0,0 +1,52 @@
STRINGTABLE DISCARDABLE
BEGIN
1 "*** Do *NOT* Localize any string that starts with '***'. They are comments to be used by localizers to identify sections. They also mark the beginning of a new 'section' within the String Table."
2 "Job Manager"
3 "Add Method received"
4 "GetServiceRequest received with return of new Service"
5 "GetServiceRequest call returned Service results"
6 "GetServiceResults received with return of results"
10 "StopTest Received"
11 "Call rejected retry"
12 "Because the specified authentication level is not supported on the remote machine, Worker will be created with no authentication on the machine, <NAME>."
13 "Only <NUMBER> workers were created and configured, because available machines were lacking."
//Remote Worker creation error message
14 "Could not create or configure a worker on machine, <NAME>."
//No errors creating remote workers message
15 "All requested workers were successfully created."
16 "Could not create or configure local worker object."
17 "Error: "
29 "*** Font information for all forms. Index 30 is the Character set, Index 31 is Font name, Index 32 is Font Size"
30 "0"
31 "Tahoma"
32 "10"
100 "*** Form U/I Captions"
101 "Job Manager" //Form Caption
102 "Current Queue Size" //Current Queue Size label
103 "Peak Queue Size" //Peak Queue Size label
104 "Total Call Count" //Total Call count label
105 "Worker Count" //Worker Count label
//Racreg32 error codes with 200 added for offset
200 "*** Racreg32 error codes with 200 added for offset"
201 "Unknown run time error occurred"
202 "No protocol was specified"
203 "No server machine name was specified"
204 "An error occurred reading from the registry"
205 "An error occurred writing to the registry"
206 "Both the ProgID and CLSID parameters were missing"
207 "There is no local server (either in-process or cross-process, 16-bit or 32-bit)"
208 "There was an error looking for the Proxy DLLs, check that they were installed properly"
32700 "*** Error Descriptions"
32749 "The Job Manager is busy. Please resubmit Service Request later."
32750 "An error occurred changing server connection settings: <NAME>."
32762 "An error occurred instantiating AEExpediter.Expediter. Callbacks can not be made."
32763 "You must first get a WithEvents object before requesting a callback through event sinking."
32766 "Invalid Callback Object"
32765 "Invalid Parameter"
32764 "No Workers could be created."
END
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/AEQUEUE.RES
LFS
BIN
View File
Binary file not shown.
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/AEQUEUE.VBP
+56
View File
@@ -0,0 +1,56 @@
Type=OleExe
Reference=*\G{244D13BD-AFDB-11CE-85D1-00AA00695286}#1.1#0#..\..\EXTERNAL\racreg32.dll#RacReg
Reference=*\G{C93809A0-684C-11D1-9D3E-0020781039AF}#1.0#0#..\AEINTRFC\AEIntrfc.tlb#Application Performance Explorer 2.0 Interfaces
Class=QueueMgr; queuemgr.cls
Module=modQueueMgr; modqueue.bas
Class=clsService; clsservc.cls
Module=modAEConstants; ..\AEInclud\modaecon.bas
Module=modVBErrors; ..\AEInclud\modvberr.bas
Module=modWin32Errors; ..\AEInclud\modwiner.bas
Class=clsPositionForm; ..\AEInclud\clsposfm.cls
Class=clsWorker; ..\AEInclud\clsworkr.cls
Class=clsQueueDelegator; clsquedl.cls
Class=Queue; queue.cls
Form=frmqueue.frm
Class=clsWorkerMachines; ..\AEInclud\clswkmac.cls
Module=modAEGlobals; ..\AEInclud\modAEGlb.bas
Module=Utility; ..\AEInclud\Utility.bas
Module=Localize; ..\AEInclud\Localize.bas
ResFile32="aequeue.res"
IconForm="frmQueueMgr"
Startup="(None)"
HelpFile=""
Title="APE Job Manager"
ExeName32="AEQueue.exe"
Path32="..\..\Retail"
Command32=""
Name="AEQueueMgr"
HelpContextID="0"
Description="Application Performance Explorer Job Manager"
CompatibleMode="1"
CompatibleEXE32="..\AECompat\AEQueue.cmp"
MajorVer=2
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Microsoft Corporation"
VersionFileDescription="Application Performance Explorer Job Manager"
VersionLegalCopyright="Copyright © 1996-1998 Microsoft Corp."
VersionLegalTrademarks="Microsoft® is a registered trademark of Microsoft Corporation. Windows(TM) is a trademark of Microsoft Corporation"
VersionProductName="Application Performance Explorer Job Manager"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=1
Unattended=0
ThreadPerObject=0
MaxNumberOfThreads=1
DebugStartupOption=0
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/CLSQUEDL.CLS
+345
View File
@@ -0,0 +1,345 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'False
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
END
Attribute VB_Name = "clsQueueDelegator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Description = "Provides an interface for the AEExpediter and the AEWorker to interact with the AEQueueMgr."
Option Explicit
'-------------------------------------------------------------------------
'The Class is public but not creatable. It is provide as an OLE interface
'for the Expediter and Workers to call. The Worker calls the GetServiceRequest Method
'to return Service results and retrieve a new Service Request.
'-------------------------------------------------------------------------
Implements APEInterfaces.IQueueDelegator
Private Function IQueueDelegator_GetServiceRequest(ByVal lWorkerID As Long, Optional ByVal sReturnServiceID As String, Optional ByVal vReturnData As Variant, Optional ByVal sReturnError As String = "") As Variant
'-------------------------------------------------------------------------
'Purpose: Worker should call this method to poll for a
' Service Request to satisfy.
'IN:
' [lWorkerID]
' Worker's ID, it is the same as its key to the gcWorkers collection
'Optional IN:
' The following optional parameters allow a Worker to return
' the results of a service request at the same time it is
' calling for a new service to accomplish.
' [sReturnServiceID]
' Service Request ID of Service whose results are being returned
' Store the returned results so the Expediter can get them
' and return them to the client application
' [vReturnData]
' Return data from the accomplished service or task. Unknown
' data type. Just store it and Expediter will get it to pass
' back to client application
' [sReturnError]
' String that contains error information that occured during
' service competion. Expediter will get this to pass back
' to client application.
'Return: Is a variant array with Service Request data if the QueueMgr
' has a Service Request for it to satify. Otherwise, a Null
' is returned. The Service ID, the Command string, UseCallback
' flag, Data Present flag, and ServiceData are passed in the
' returned array
'Effects:
' [gbBusyGetServiceRequest]
' is true during procedure
' [gcQueue]
' The Service Request item, a clsService class object, in the
' collection will have its status property changed to giDELEGATED_TO_WORKER
' if it is returned to the Worker
' Another Service Request item in the collection whose results
' are being returned may have it status property changed to
' giHAVE_SERVICE_RESULTS
' [gcWorkers]
' An item's Busy flag that corresponds with calling Worker is
' flipped to false if no Service Request is returned. If a
' Service Request is returned it is set to true.
'Assumes:
' [gcWorkers]
' Is a collection of valid AEWorker.Worker objects
' [Calling Object]
' Is a Worker in the gcWorkers collection and is passing an
' ID that matches the key to it in the gcWorkers collection
' [gcQueue]
' Is a collection of clsService objects
'-------------------------------------------------------------------------
'First check to see if there is an Service request in the queue
'Pass back a variant array to the Worker if there is another Service
Dim oService As clsService 'Will be the clsService object to store the
'passed results in and then it will be the
'clsService object to retrieve Service Request
'Data from and pass back to worker
Dim sKeyToRemove As String 'Key of clsService object in gcQueue to remove
Dim oa As clsService 'clsService object used in For...Next loop
Dim bGotService As Boolean 'Flag meaing Service Request is chosen to pass back
Dim vServiceData(3) As Variant 'Array that will contain Service request data
'to be returned to Worker
Dim lCount As Long 'Count of items in gcQueue
Dim l As Long 'For...Next counter
Dim oWork As clsWorker 'clsWorker object that contains a reference to the
'calling Worker object
On Error GoTo QueueDelegator_GetServiceRequestError
gbBusyGetServiceRequest = True
'Get the clsWorker object that contains the Worker that is calling
Set oWork = gcWorkers.Item(CStr(lWorkerID))
'See if Service Request results were returned. If they were
'store the Service Request results in gcQueue in the clsService
'object if the objects UseCallback property is true. If it is
'false, ignore any results and remove item from queue now.
If IsNumeric(sReturnServiceID) And (Not gbStopTest) Then
'We have a return, now see if results should be stored
'for expediter to get and return to client application
Set oService = gcQueue.Item(sReturnServiceID)
With oService
Select Case .CallBackMode
Case giUSE_DEFAULT_CALLBACK, giUSE_PASSED_CALLBACK, giRETURN_BY_SYNC_EVENT
'store values and change status flag
LogEvent giGETREQUEST_RECEIVED_RETURNED_RESULTS, sReturnServiceID
.Status = giHAVE_SERVICE_RESULTS
.ReturnError = sReturnError
If Not IsMissing(vReturnData) Then
'Check what data type vReturnData is
'in order to determine how to handle it
Select Case VarType(vReturnData)
Case vbEmpty, vbNull
.ReturnData = Null
Case vbObject, vbError, vbDataObject
Set .ReturnData = vReturnData
Case Else
.ReturnData = vReturnData
End Select
End If
gbHaveServiceResults = True
Case Else
'if a callback is not to be returned just
'remove the clsService object from gcQueue
gcQueue.Remove sReturnServiceID
End Select
End With
Set oService = Nothing
End If
'Exit sub if Stopping Queue
If gbStopTest Then
GoTo NoServiceToReturn
End If
'See if the calling Worker is Marked for removal. If it is
'return the integer value giCLOSE_WORKER_NOW instead of returning
'a Service request. Also, remove the clsWorker object from
'gcWorkers so that when the local reference to it (oWork)
'goes out of scope the Worker will unload
lCount = gcQueue.Count
If oWork.RemoveMe Then
gcWorkers.Remove CStr(lWorkerID)
'Update worker count U/I
If gbShow Then
With frmQueueMgr.lblWorkerCount
.Caption = gcWorkers.Count
.Refresh
End With
End If
IQueueDelegator_GetServiceRequest = giCLOSE_WORKER_NOW
Exit Function
Else
If lCount > 0 Then
'Pass another Service throught the parameters passed ByRef
'It seems that this procedure or the Delegate procedure is dropped into
'using the same oService in gcQueue so Status flag is
'added so it can be flipped immediately
bGotService = False
'Use For...Next instead of For...Each to make sure that
'correct priority is given to items in the collection
For l = 1 To gcQueue.Count
'If an item is removed during this loop by another process
'an Invalid Procedure call error will be produced if
'try to reference a object that no longer exists
On Error Resume Next
Set oa = gcQueue(l)
If Err.Number = ERR_INVALID_PROCEDURE_CALL Then
On Error GoTo QueueDelegator_GetServiceRequestError
Exit For
End If
On Error GoTo QueueDelegator_GetServiceRequestError
If oa.Status = giWAITING_FOR_WORKER Then
oa.Status = giDELEGATED_TO_WORKER
sKeyToRemove = CStr(oa.ID)
Set oService = oa
bGotService = True
Exit For
End If
Next
If Not bGotService Then
'event though gcQueue.Count is greater than
'zero all the items are already delgated so
'Mark the worker as not busy and exit
GoTo NoServiceToReturn
End If
'Fill the variant array to be returned
With oService
LogEvent giGETREQUEST_RECEIVED_NEW_SERVICE, .ID
vServiceData(giSERVICE_ID_ELEMENT) = .ID
vServiceData(giCOMMAND_ELEMENT) = .Command
vServiceData(giDATA_PRESENT_ELEMENT) = .DataPresent
If .DataPresent Then
'Check what data type vService return is
'in order to determine how to handle it
Select Case VarType(.Data)
Case vbEmpty, vbNull
vServiceData(giSERVICE_DATA_ELEMENT) = Null
Case vbObject, vbError, vbDataObject
Set vServiceData(giSERVICE_DATA_ELEMENT) = .Data
Case Else
vServiceData(giSERVICE_DATA_ELEMENT) = .Data
End Select
End If
End With
Set oService = Nothing
IQueueDelegator_GetServiceRequest = vServiceData()
On Error GoTo QueueDelegator_GetServiceRequestError
Else
NoServiceToReturn:
'If there is not pending Service request
'mark Busy equal false in the clsWorker class
'object that has a reference to the Worker
'calling the GetServiceRequest method.
If gbShow Then frmQueueMgr.lblQueue = 0
oWork.Busy = False
IQueueDelegator_GetServiceRequest = Null
End If
End If
'Display stats
If gbShow Then frmQueueMgr.lblQueue = lCount
If lCount > glPeakQueueSize Then
glPeakQueueSize = lCount
If gbShow Then frmQueueMgr.lblPeak = glPeakQueueSize
End If
gbBusyGetServiceRequest = False
If gbStopTest And Not gbBusyAdding And Not gbBusyGetServiceResults Then StopQueue
Exit Function
QueueDelegator_GetServiceRequestError:
LogError Err, gsNULL_SERVICE_ID
Err.Raise Err.Number, Err.Source, Err.Description
Exit Function
End Function
Private Function IQueueDelegator_GetServiceResults() As Variant
'-------------------------------------------------------------------------
'Purpose: This method is provided for the Expediter to call and retrieve
' all completed Service Request results and there respective
' callback objects
'Return: Is a variant array with Service Results if the QueueMgr
' has completed Service Results for it to satify. Otherwise, a Null
' is returned. The Service ID, the Data to be returned, the Callback
' object, and the Error description string are returned with in
' The variant array for each Service Result returned. The array
' will have two dimensions. The first dimension will have an
' index to represent each data element of the Service Results --
' see modAEConstants for the index constants--the second dimension
' will have an index for each Service Result
'Effects:
' [gbBusyGetServiceResults]
' Is true during this procedure
' [gcQueue]
' Any clsService object with its Status property equaling
' giHAVE_SERVICE_RESULTS will be removed.
'-------------------------------------------------------------------------
Dim vaResults As Variant 'Variant array to be returned to Expediter
Dim lResultCount As Long 'Count of results added to Result array
Dim oService As clsService 'Object for For...Each loop
Dim lUB As Long 'Upper Bound of the 2nd dimension of vaResults
gbBusyGetServiceResults = True
'Check the gbHaveServiceResults flag so we don't check ever
'clsService object in gcQueue if we know that there are no
'ready Service Results
If gbHaveServiceResults Then
gbHaveServiceResults = False
ReDim vaResults(giRESULT_DIMENSION_ONE, giRESULT_ARRAY_REDIM_CHUNK_SIZE)
lUB = giRESULT_ARRAY_REDIM_CHUNK_SIZE
'Check if any clsService objects in gcQueue are ready to be returned
For Each oService In gcQueue
With oService
If oService.Status = giHAVE_SERVICE_RESULTS Then
'Put the data of this clsService object in
'the array then remove the object from the collection
'See if vaResults needs redimensioned
If lResultCount > lUB Then
lUB = lUB + giRESULT_ARRAY_REDIM_CHUNK_SIZE
ReDim Preserve vaResults(giRESULT_DIMENSION_ONE, lUB)
End If
'Get values
vaResults(giRESULT_ID_ELEMENT, lResultCount) = .ID
vaResults(giRESULT_CALLBACK_TYPE_ELEMENT, lResultCount) = .CallBackMode
Select Case .CallBackMode
Case giUSE_PASSED_CALLBACK, giUSE_DEFAULT_CALLBACK
Set vaResults(giRESULT_CALLBACK_ELEMENT, lResultCount) = .CallBack
Case giRETURN_BY_SYNC_EVENT
Set vaResults(giRESULT_CALLBACK_ELEMENT, lResultCount) = .EventObject
End Select
vaResults(giRESULT_ERROR_ELEMENT, lResultCount) = .ReturnError
'Check what data type .ReturnData is
'in order to determine how to handle it
Select Case VarType(.ReturnData)
Case vbEmpty, vbNull
vaResults(giRESULT_DATA_ELEMENT, lResultCount) = Null
Case vbObject, vbError, vbDataObject
Set vaResults(giRESULT_DATA_ELEMENT, lResultCount) = .ReturnData
Case Else
vaResults(giRESULT_DATA_ELEMENT, lResultCount) = .ReturnData
End Select
'Remove the current clsService object from gcQueue
gcQueue.Remove CStr(.ID)
lResultCount = lResultCount + 1
'exit the loop if the array has reached the max size
'the rest of the results will be returned on another call
If lResultCount - 1 = giRESULT_ARRAY_MAX_SIZE Then
gbHaveServiceResults = True ' Make sure the remaining items are processed
Exit For
End If
End If
End With
Next
'Check if any results were put in the array
'If they were redimension the array to trim of indexes that do not have
'data in them and return the array as the result of this function
'If no results were put in the array return null
If lResultCount >= 1 Then
LogEvent giGETRESULTS_RECEIVED_RETURNED_RESULTS, gsNULL_SERVICE_ID
ReDim Preserve vaResults(giRESULT_DIMENSION_ONE, lResultCount - 1)
IQueueDelegator_GetServiceResults = vaResults
Else
IQueueDelegator_GetServiceResults = Null
End If
End If
'Display stats
If gbShow Then frmQueueMgr.lblQueue = gcQueue.Count
If gbStopTest And Not gbBusyGetServiceRequest And Not gbBusyAdding Then StopQueue
gbBusyGetServiceResults = False
End Function
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/CLSSERVC.CLS
+36
View File
@@ -0,0 +1,36 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'False
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
END
Attribute VB_Name = "clsService"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'-------------------------------------------------------------------------
'This class is used a structure for holding queued
'Service requests. Objects of this class are
'added to the gcQueue collection
'-------------------------------------------------------------------------
Public ID As String 'Service Request ID
Public Command As String 'Service Command used passed to Worker
Public Data As Variant 'Service Data passed to Worker
Public CallBack As APEInterfaces.IClientCallback 'Callback object Expediter will use to call
'Client application back
Public CallBackMode As Integer 'Defines if and how data should be returned
'to client. See "Callback mode keys" in modAEConstants
Public EventObject As Object 'sync object to return results through
'back to calling client
Public Status As Integer 'Status flag, see global constants
Public DataPresent As Boolean 'Flag, if true, data needs to goto to Service object
'Pass Data to Service object
Public ReturnData As Variant 'Data to be returned to Client application. The
'results of a Service Request processed by a
'worker. The Expediter will get this.
Public ReturnError As String 'Error description to return to client. Description
'of error that occured while processing service
'request.
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/FRMQUEUE.FRM
+258
View File
@@ -0,0 +1,258 @@
VERSION 5.00
Begin VB.Form frmQueueMgr
BorderStyle = 1 'Fixed Single
Caption = "Queue Manager"
ClientHeight = 2175
ClientLeft = 7170
ClientTop = 1785
ClientWidth = 3915
ClipControls = 0 'False
Icon = "frmqueue.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 2175
ScaleWidth = 3915
StartUpPosition = 3 'Windows Default
Begin VB.ListBox lstLog
Height = 525
IntegralHeight = 0 'False
Left = 3330
TabIndex = 0
Top = 1440
Visible = 0 'False
Width = 525
End
Begin VB.Label lblCaption
BackStyle = 0 'Transparent
Caption = "Worker Count"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 3
Left = 195
TabIndex = 9
Top = 1200
Width = 2535
End
Begin VB.Label lblWorkerCount
BackStyle = 0 'Transparent
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 2800
TabIndex = 8
Top = 1200
Width = 1000
End
Begin VB.Label lblCount
BackStyle = 0 'Transparent
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 2800
TabIndex = 7
Top = 840
Width = 1000
End
Begin VB.Label lblPeak
BackStyle = 0 'Transparent
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 2800
TabIndex = 6
Top = 480
Width = 1000
End
Begin VB.Label lblQueue
BackStyle = 0 'Transparent
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 2800
TabIndex = 5
Top = 120
Width = 1000
End
Begin VB.Label lblCaption
BackStyle = 0 'Transparent
Caption = "Total Call Count"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 2
Left = 195
TabIndex = 4
Top = 840
Width = 2535
End
Begin VB.Label lblCaption
BackStyle = 0 'Transparent
Caption = "Peak Queue Size"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 1
Left = 195
TabIndex = 3
Top = 480
Width = 2535
End
Begin VB.Label lblCaption
BackStyle = 0 'Transparent
Caption = "Current Queue Size"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 0
Left = 195
TabIndex = 2
Top = 120
Width = 2535
End
Begin VB.Label lblStatus
BackStyle = 0 'Transparent
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 500
Left = 200
TabIndex = 1
Top = 1570
Width = 3500
WordWrap = -1 'True
End
End
Attribute VB_Name = "frmQueueMgr"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Form_Load()
'-------------------------------------------------------------------------
'Effects:
' Position form and load captions from string resource
'-------------------------------------------------------------------------
'Use clsPositionForm object to move
'Form to settings saved in registry
Dim oPosition As clsPositionForm
Set oPosition = New clsPositionForm
'Set U/I captions
ApplyFontToForm Me
Caption = LoadResString(giFORM_CAPTI0N)
lblCaption(0).Caption = LoadResString(giCURRENT_QUEUE_CAPTION)
lblCaption(1).Caption = LoadResString(giPEAK_QUEUE_CAPTION)
lblCaption(2).Caption = LoadResString(giTOTAL_CALL_CAPTION)
lblCaption(3).Caption = LoadResString(giWORKER_COUNT_CAPTION)
'Condition compile toggles between retail U/I and
'Debug U/I that displays a list box that displays all
'events as they occur
#If ccShowList Then
oPosition.Move Me, True
lstLog.Visible = True
lblStatus.Visible = False
lblPeak.Visible = False
lblCount.Visible = False
lblQueue.Visible = False
lblCaption(0).Visible = False
lblCaption(1).Visible = False
lblCaption(2).Visible = False
#Else
oPosition.Move Me, False
Width = giDEFAULT_FORM_WIDTH
Height = giDEFAULT_FORM_HEIGHT
#End If
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'Only unload if called by code.
If UnloadMode = vbFormControlMenu Then Cancel = True
End Sub
Private Sub Form_Resize()
#If ccShowList Then
Dim lX As Long
Dim lY As Long
If Me.ScaleHeight >= 2 * glFORM_MARGIN Then lY = (Me.ScaleHeight - (2 * glFORM_MARGIN)) Else lY = (2 * glFORM_MARGIN) - Me.ScaleHeight
If Me.ScaleWidth >= 2 * glFORM_MARGIN Then lX = (Me.ScaleWidth - (2 * glFORM_MARGIN)) Else lX = (2 * glFORM_MARGIN) - Me.ScaleWidth
lstLog.Move glFORM_MARGIN, glFORM_MARGIN, lX, lY
#End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Use clsPositionForm object to save
'forms position in registry
Dim oPosition As clsPositionForm
Set oPosition = New clsPositionForm
oPosition.Save Me
gbShow = False
End Sub
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/FRMQUEUE.FRX
BIN
View File
Binary file not shown.
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/MODQUEUE.BAS
+700
View File
@@ -0,0 +1,700 @@
Attribute VB_Name = "modQueueMgr"
Option Explicit
'-------------------------------------------------------------------------
'The project is the QueueMgr component of the Application Performance Explorer
'The QueueManager receives Service Requests from Client applications and
'places the requests in a Queue. When it receives a request it passes
'a received callback object to the Expediter if needed. Workers poll the
'QueueMgr taking Service Requests and accomplishing the service. When
'the Worker takes a Service request it is removed from the Queue.
'The Queue Manager creates the Worker(s), the Logger, and the Expediter
'
'Key Files:
' frmQueue.frm Is the only and main form of the app
' clsPosFm.cls Is a tool to save the forms position to the registry
' clsServc.cls Is a class used to store Service Request Data
' clsWorkr.cls Is a class used to store a Worker object and its related
' data
' QueueMgr.cls Is a creatable multi-use class that provides the
' OLE interface for the APE Manager to call
' clsQueDl.cls Is a non-creatable public class that is instanciated and
' passed to the Workers and expediter for them to call
' Queue.cls Is a creatable multi-use class that provides the OLE
' interface for client applications to add service
' requests to the Queue
'-------------------------------------------------------------------------
'Declarations
Declare Function GetTickCount Lib "Kernel32" () As Long
'U/I Caption ResourceString keys
Public Const giFORM_CAPTI0N As Integer = 101
Public Const giCURRENT_QUEUE_CAPTION As Integer = 102
Public Const giPEAK_QUEUE_CAPTION As Integer = 103
Public Const giTOTAL_CALL_CAPTION As Integer = 104
Public Const giWORKER_COUNT_CAPTION As Integer = 105
'Constants
Public Const gbSHOW_FORM_DEFAULT As Boolean = False
Public Const gbLOG_DEFAULT As Boolean = False
Public Const gsPROTOCOL_DEFAULT As String = "ncacn_ip_tcp"
Public Const glAUTHENTICATION_DEFAULT As Long = 1
Public Const giWORKER_QUANTITY_DEFAULT As Integer = 1
Public Const gbWORKER_EARLYBIND_DEFAULT As Integer = True
Public Const gbPERSISTENT_QUEUE_DEFAULT As Boolean = False
Public Const glMAX_QUEUE_SIZE_DEFAULT As Long = 20000 'This was chosen as the ideal MaxQueue size on
'on a Pentium 100 with 32 meg, running NT4
'This allows the queue to get large enough for
'the user to see a performance hit, but not so
'large that recovery is difficult
Public Const giERROR_THRESHOLD As Integer = 32700
Public Const glMAX_ID As Long = 2147483647
Public Const giMAX_WORKERS As Integer = 30
Public Const giMAX_ALLOWED_RETRIES As Integer = 500
Public Const giRETRY_WAIT_MIN As Integer = 500 'Retry Wait is measure in DoEvent cycles
Public Const giRETRY_WAIT_MAX As Integer = 2500
Public Const giRESULT_ARRAY_REDIM_CHUNK_SIZE = 20
Public Const giRESULT_ARRAY_MAX_SIZE = 200
Public Const giRACREG_ERROR_CODE_OFFSET = 200 'Add offset to racreg32 error codes
'to make corresponding resource string key
'Status codes for Status property of clsService
Public Const giCLIENT_IS_ADDING As Integer = 0 'Client is currently in the Add method for the
'respective Service reaquest. The request should
'not be delegated yet.
Public Const giWAITING_FOR_WORKER As Integer = 1 'Service request is ready to be taken by worker
Public Const giDELEGATED_TO_WORKER As Integer = 2 'Worker is processing this service request
Public Const giHAVE_SERVICE_RESULTS As Integer = 3 'Worker has returned results for this Service
'request. It is ready to be taken by Expediter
'User Defined Errors which also serve as string
'resource indexes
Public Const giQUEUE_MGR_IS_BUSY As Integer = 32749
Public Const giFIRST_GET_WITHEVENTS_OBJECT As Integer = 32763
Public Const giNO_WORKERS_CREATED As Integer = 32764
Public Const giINVALID_PARAMETER As Integer = 32765
Public Const giINVALID_CALLBACK As Integer = 32766
Public Const giCOULD_NOT_CREATE_EXPEDITER As Integer = 32762
Public Const giCONNECTION_SETTING_FAILED As Integer = 32750 'An error was returned by RacReg32
'String resourse strings for logging messages
Public Const giQUEUE_NAME As Integer = 2
Public Const giADD_RECEIVED As Integer = 3
Public Const giGETREQUEST_RECEIVED_NEW_SERVICE As Integer = 4
Public Const giGETREQUEST_RECEIVED_RETURNED_RESULTS As Integer = 5
Public Const giGETRESULTS_RECEIVED_RETURNED_RESULTS As Integer = 6
Public Const giSTOP_TEST_RECEIVED As Integer = 10
Public Const giCALL_REJECTED_RETRY As Integer = 11
Public Const giUSING_NO_AUTHENTICATION As Integer = 12
Public Const giONLY_N_WORKERS_CREATED As Integer = 13
Public Const giCOULD_NOT_CREATE_WORKER_ON_MACHINE As Integer = 14
Public Const giALL_WORKERS_CREATED As Integer = 15
Public Const giCOULD_NOT_CREATE_LOCAL_WORKER As Integer = 16
Public Const giERROR_PREFIX As Integer = 17
Public Const giFONT_CHARSET_INDEX As Integer = 30
Public Const giFONT_NAME_INDEX As Integer = 31
Public Const giFONT_SIZE_INDEX As Integer = 32
'Global variables
Public glMaxQueueSize As Long 'Maximum allowed size of gcQueue
Public glAddCallCount As Long 'Total calls made to Queue.Add
Public glPeakQueueSize As Long 'Largest size of the collection of Service requests
Public gbLog As Boolean 'If True log QueueMgr Events
Public goExpediter As APEInterfaces.IExpediter 'Expediter class object
Public gcQueue As Collection 'Collection of clsService class objects
'which contain a data structure for holding
'Service request.
Public gcWorkers As Collection 'Collection of clsWorker class objects
Public gcWorkerMachines As Collection 'Collection of clsWorkerMachines objects used
'keep track of how many worker objects are on
'each remote worker machine.
Public goLogger As APEInterfaces.ILogger 'Logger object
Public gbShow As Boolean 'If True show frmQueueMgr
Public glInstances As Long 'Count of number of instances
'of this class
Public giWorkerCount As Integer 'Number of Worker instanciated, This can be different
'than gcWorkers.Count if a Worker in the collection
'is marked for removal it will not be included in giWorkerCount
Public gbLogWorkers As Boolean 'Flag to track status of
'Worker property Log
Public gbPersistentServices As Boolean 'Flag keeps track of Worker
'property PersistentServices
'If true Workers keep reference to
'all Service objects used else they
'drop references after each use.
Public gbEarlyBindServices As Boolean 'Flag to track status of
'Worker property EarlyBound
Public gbShowExpediter As Boolean 'Stores current Expediter property Show
Public gbLogExpediter As Boolean 'Stores current Expediter property Log
Public gbStopTest As Boolean 'Stop Test flag, checked by many procedures
'that will discontinue their processes if true
Public gbBusyAdding As Boolean 'If true, in Queue.Add method
Public gbBusyGetServiceRequest As Boolean 'If true, in clsQueueDelegator.GetServiceRequest method
Public gbBusyGetServiceResults As Boolean 'If true, in clsQueueDelegator.GetServiceResults method
Public gbUnloading As Boolean 'Flag used by Class_terminate
Public gbHaveServiceResults As Boolean 'If true, there are Service Request results to return
'to the Expediter when it polls
Public gsProtocol As String 'Protocol sequence to use when connecting to Workers
Public glAuthentication As Long 'Authentication level to use when connecting to Workers
Public gbUseDCOM As Boolean 'If true use DCOM to create workers instead of Remote Automation
Public gbFailedToCreateExpediter As Boolean
Public Sub CountInitialize()
'-------------------------------------------------------------------------
'Purpose: Keep track of number instances of QueueMgr and Queue
' To be called by a public creatable class in its initialize
' event. To keep track of how many public creatable objects
' are initialized. Initialize the QueueMgr application if
' this is the first time it is called.
'Effects:
' If this is the first instanciation
' Put the QueueMgr in a "Ready" state. Load expediter, and Workers
' Set default properties, Show form and load logger if necessary.
' [glInstances]
' increments by one
'-------------------------------------------------------------------------
Dim i As Integer
Dim oWork As clsWorker 'Object storing Workers and related informantion
Dim oService As clsService 'Object storing service requests and results
Dim oWorkerMachine As clsWorkerMachines 'Object that stores how many
'Workers are on what machines
Dim sProgID As String 'ProgID trying to be created
'used for error handling
Dim sReturn As String 'Return of SetWorkersOnMachine function
Dim bCreatingExpediter As Boolean
On Error GoTo CountInitializeError
glInstances = glInstances + 1
If glInstances = 1 Then
App.OleServerBusyRaiseError = True
App.OleServerBusyTimeout = 10000
'Set default property values
gbShow = gbSHOW_FORM_DEFAULT
gbLog = gbLOG_DEFAULT
gsProtocol = gsPROTOCOL_DEFAULT
glAuthentication = glAUTHENTICATION_DEFAULT
gbEarlyBindServices = gbWORKER_EARLYBIND_DEFAULT
glMaxQueueSize = glMAX_QUEUE_SIZE_DEFAULT
'Create Logger class object early so
'potential errors could be logged
sProgID = "AELogger.Logger"
If gbLog Then Set goLogger = CreateObject("AELogger.Logger")
'gbPersistentQueue = gbPERSISTENT_QUEUE_DEFAULT
'Create Expediter class object
sProgID = "AEExpediter.Expediter"
bCreatingExpediter = True
Set goExpediter = CreateObject("AEExpediter.Expediter")
Set goExpediter.QueueMgrRef = New clsQueueDelegator
bCreatingExpediter = False
'Load frmQueueMgr because it has a timer
Load frmQueueMgr
'Create collection objects
Set gcWorkers = New Collection
Set gcQueue = New Collection
Set gcWorkerMachines = New Collection
'Add an item to represent number of workers on the local machine
Set oWorkerMachine = New clsWorkerMachines
gcWorkerMachines.Add oWorkerMachine
'Load the default amount of workers and add
'them to the gcWorkers Collection
sReturn = SetWorkersOnMachine(False, "", giWORKER_QUANTITY_DEFAULT)
'Only show the form if gbShow is true
If gbShow Then
frmQueueMgr.Show
With frmQueueMgr
.lblCount.Caption = 0
.lblPeak.Caption = 0
.lblQueue.Caption = 0
.lblWorkerCount.Caption = gcWorkers.Count
.lblCount.Refresh
.lblPeak.Refresh
.lblQueue.Refresh
.lblWorkerCount.Refresh
End With
End If
gbUnloading = False
'call start test in the Expediter so it
'will start polling the QueueMgr
goExpediter.StartTest
End If
Exit Sub
CountInitializeError:
Select Case Err.Number
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")
Select Case sProgID
Case "AELogger.Logger"
Set goLogger = oInstancer.Object("AELogger.Logger")
Case "AEExpediter.Expediter"
Set goExpediter = oInstancer.Object("AEExpediter.Expediter")
End Select
Set oInstancer = Nothing
Resume Next
Case Else
If bCreatingExpediter Then gbFailedToCreateExpediter = True
LogError Err, gsNULL_SERVICE_ID
Resume Next
End Select
End Sub
Public Sub CountTerminate()
'-------------------------------------------------------------------------
'Purpose: Keep track of number instances of QueueMgr and Queue
' To be called by a public creatable class in its terminate
' event. To keep track of how many public creatable objects
' are initialized. Terminate the QueueMgr application if
' this is the last time called.
'Effects:
' Unload all objects, and unload form so that this application
' will close
' [glInstances]
' decrements by one
'-------------------------------------------------------------------------
Dim oWorker As clsWorker
On Error GoTo Class_TerminateError
glInstances = glInstances - 1
'If already started unloading don't check
'instance count again
If Not gbUnloading Then
If glInstances = 0 Then
gbUnloading = True
goExpediter.StopTest
For Each oWorker In gcWorkers
oWorker.Worker.ShutDown
Next
For Each oWorker In gcWorkers
Set oWorker.Worker = Nothing
Set oWorker = Nothing
Next
Set goLogger = Nothing
Set gcWorkers = Nothing
giWorkerCount = 0
Set gcWorkerMachines = Nothing
Set goExpediter = Nothing
Set gcQueue = Nothing
Unload frmQueueMgr
End If
End If
Exit Sub
Class_TerminateError:
LogError Err, gsNULL_SERVICE_ID
Resume Next
End Sub
Public Sub LogEvent(intMessage As Integer, sServiceID As String)
'-------------------------------------------------------------------------
'Purpose: Receives Message key which is used to look
' up a resource string. The logrecord is sent to the
' Logger object if gbLog is true
'In: [intMessage]
' A valid Resource string key for the message to be logged
' [sServiceID]
' Service Request ID to be logged
'Assumption:
' If gbLog is true then goLogger is a valid reference to
' AELogger.Logger class object
'-------------------------------------------------------------------------
On Error GoTo LogEventError
If gbLog And Not gbStopTest Then
goLogger.Record LoadResString(giQUEUE_NAME), sServiceID, LoadResString(intMessage), GetTickCount()
End If
'If the form is visible display log on form
#If ccShowList Then
DisplayString sServiceID & gsSEPERATOR & LoadResString(intMessage)
#End If
Exit Sub
LogEventError:
LogError Err, sServiceID
Exit Sub
End Sub
Public Sub LogText(sMsg As String, sServiceID As String)
'-------------------------------------------------------------------------
'Purpose: Passes that passed string and ServiceID as a log record
' to the logger
'In: [sMsg]
' String to be logged
' [sServiceID]
' Service Request ID to be logged
'Assumption:
' If gbLog is true then goLogger is a valid reference to
' AELogger.Logger class object
'-------------------------------------------------------------------------
On Error GoTo LogTextError
If gbLog And Not gbStopTest Then
goLogger.Record LoadResString(giQUEUE_NAME), sServiceID, sMsg, GetTickCount()
End If
'If the form is visible display log on form
#If ccShowList Then
DisplayString sServiceID & gsSEPERATOR & sMsg
#End If
Exit Sub
LogTextError:
LogError Err, sServiceID
Exit Sub
End Sub
Public Sub LogError(ByVal oErr As ErrObject, sServiceID As String)
'-------------------------------------------------------------------------
'Purpose: Display error description on forms Status box if the form is
' visible; log error if logging is on
'In: [oErr]
' Valid error object
' [sServiceID]
' Service Request ID logged with the error message
'Assumption:
' If gbShow is true the form is loaded and visible
' If gbLog is true the goLogger is a valid AELogger.Logger class
' object
'-------------------------------------------------------------------------
Dim s As String
s = LoadResString(giERROR_PREFIX) & Str$(oErr.Number) & gsSEPERATOR & oErr.Source & gsSEPERATOR & oErr.Description
#If ccShowList Then
If Not gbShow Then
frmQueueMgr.Show
gbShow = True
End If
DisplayString s
#Else
If oErr.Number <> 0 Then DisplayStatus oErr.Description
#End If
If gbLog And glInstances <> 0 Then
goLogger.Record LoadResString(giQUEUE_NAME), sServiceID, s, GetTickCount()
End If
End Sub
Sub DisplayStatus(s As String)
'-------------------------------------------------------------------------
'Purpose: If gbShow is true, displays passed string on forms status box
'Assumes: If gbShow is true, form is loaded and visible
'-------------------------------------------------------------------------
If gbShow Then AlignTextToBottom frmQueueMgr.lblStatus, s
End Sub
Sub DisplayString(sText As String)
'-------------------------------------------------------------------------
'Purpose: Adds the passed text to to the list box. Only used if conditional
' compile ccShowList is true.
'Assumes: If gbShow is true, form is visible
' If ccShowList is true, lstLog is visible and positioned
'-------------------------------------------------------------------------
'Controls the length of the list box
'and sets ListIndex
#If ccShowList Then
Dim lstLog As ListBox
If gbShow Then
Set lstLog = frmQueueMgr.lstLog
If lstLog.ListCount = giLIST_BOX_MAX Then lstLog.Clear
lstLog.AddItem sText, 0
DoEvents
End If
#End If
End Sub
Function gFormatPath(sPath As String) As String
'-------------------------------------------------------------------------
'Purpose: Assures that the passed path has a "\" at the end of it
'IN:
' [sPath]
' a valid path name
'Return: the same path with a "\" on the end if it did not already
' have one.
'-------------------------------------------------------------------------
If Right$(sPath, 1) <> "\" Then
gFormatPath = sPath & "\"
Else
gFormatPath = sPath
End If
End Function
Sub StopQueue()
'-------------------------------------------------------------------------
'Purpose: Stops processing of Service Requests by deleging the pending
' requests
'Assumes: Assumes that clients have already stopped posting new requests
'-------------------------------------------------------------------------
LogEvent giSTOP_TEST_RECEIVED, gsNULL_SERVICE_ID
DisplayStatus LoadResString(giSTOP_TEST_RECEIVED)
Set gcQueue = Nothing
Set gcQueue = New Collection
End Sub
Public Function SetWorkersOnMachine(bRemote As Boolean, sMachineName As String, lQuantityOnMachine As Long) As String
'-------------------------------------------------------------------------
'Purpose: Sets the quantity of instanciated Workers on a particular machine
'IN:
' [bRemote]
' If true adjust number of workers on a remote machine; else,
' adjust the number on the local machine.
' [sMachineName]
' Name of machine to adjust the level of instanciated Workers
' [lQuantityOnMachine]
' Number of Instantiated Workers that should be on specified
' machine.
'Return: Discription of Errors that should be displayed to user
'Effects:
' [gcWorkers]
' The number of Workers in this collection will be adjusted
' [gcWorkerMachines]
' An item may be added or removed or edited
'-------------------------------------------------------------------------
Dim oRacReg As RacReg.RegClass 'Object to set automation connection settings
Dim oWorkerMachine As clsWorkerMachines 'Object that stores how many workers are on
'a machine, retrieved from global collection
Dim lWorkerToRemove As Long 'ID of Worker found to remove
Dim oWork As clsWorker 'clsWorker object that hold reference to a Worker
'and information related to it
Dim oWorkerProvider As APEInterfaces.IWorkerProvider 'Server that can be instanciated on remote
'machines to provide Worker objects
Dim lAdd As Long 'New ID for New Worker
Dim sErrors As String 'Discription of Errors that will be returned
Dim bAddingWorker As Boolean 'If true, adding and configuring worker
'used by error handling
Dim iRetry As Integer 'Error retry counter
Dim iResult As Integer 'RacReg error code
On Error GoTo SetWorkersOnMachineError
'Validate lQuantityOnMachine
If lQuantityOnMachine < 0 Then lQuantityOnMachine = 0
'Set registry for local or remote machine name
Set oRacReg = New RacReg.RegClass
If bRemote Then
If gbUseDCOM Then
iResult = oRacReg.SetDCOMServerSettings(True, "AEWorkerProvider.WorkerProvider", , sMachineName)
Else
iResult = oRacReg.SetAutoServerSettings(True, "AEWorkerProvider.WorkerProvider", , sMachineName, gsProtocol, glAuthentication)
End If
Else
'Make sure the Machine name string is zero length
sMachineName = ""
'Make sure AEWorker.Worker is registered for local instanciation
'Because Clients may have been run on this machine and may have
'left the connection settings remote if they did not unload properly
iResult = oRacReg.SetAutoServerSettings(False, "AEWorker.Worker")
End If
If iResult <> 0 Then GoTo SetWorkersOnMachine_RacRegError
'Get the clsWorkerMachines object to store information in
If Not bRemote Then
'it is definitely the first item in the collection
Set oWorkerMachine = gcWorkerMachines.Item(1)
Else
'if it is in the collection it is stored by a key
'equaling the machine name
'If error equals ERR_INVALID_PROCEDURE_CALL there
'are no Workers on specified machine and no clsWorkerMachines
'class object to represent them
On Error Resume Next
Set oWorkerMachine = gcWorkerMachines.Item(sMachineName)
If Err.Number = ERR_INVALID_PROCEDURE_CALL Then
On Error GoTo SetWorkersOnMachineError
'Don't create a new clsWorkerMachine object of
'lQuantityOnMachine is zero
If lQuantityOnMachine <= 0 Then Exit Function
Set oWorkerMachine = New clsWorkerMachines
'If an error occurs creating WorkerProvider the current machine name
'can not be used. Treat error as if a Worker can not be created on
'paticular machine.
bAddingWorker = True
Set oWorkerMachine.WorkerProvider = CreateObject("AEWorkerProvider.WorkerProvider")
bAddingWorker = False
gcWorkerMachines.Add oWorkerMachine, sMachineName
With oWorkerMachine
.Remote = True
.MachineName = sMachineName
End With
End If
On Error GoTo SetWorkersOnMachineError
Set oWorkerProvider = oWorkerMachine.WorkerProvider
End If
'Now see if more workers need destroyed on this machine
With oWorkerMachine
If .WorkerKeys.Count > lQuantityOnMachine Then
Do Until .WorkerKeys.Count <= lQuantityOnMachine
'Find a worker on this machine
lWorkerToRemove = .WorkerKeys(.WorkerKeys.Count)
.WorkerKeys.Remove .WorkerKeys.Count
'Remove the found worker
'Do not destroy the Worker if it is busy
'instead just flip its RemoveMe flag
giWorkerCount = giWorkerCount - 1
If gcWorkers.Item(CStr(lWorkerToRemove)).Busy Then
gcWorkers.Item(CStr(lWorkerToRemove)).RemoveMe = True
Else
iRetry = 0
Set oWork = gcWorkers.Item(CStr(lWorkerToRemove))
oWork.Worker.ShutDown
Set gcWorkers.Item(CStr(lWorkerToRemove)).Worker = Nothing
gcWorkers.Remove CStr(lWorkerToRemove)
End If
Loop
Else
'Else lQuantityOnMachine must be greater than .WorkerKeys.count
'So add to the collection
bAddingWorker = True
Do Until .WorkerKeys.Count = lQuantityOnMachine
'Choose a unique key
lAdd = GetUniqueID
Set oWork = New clsWorker
oWork.Busy = False
'Get a new Worker object
If bRemote Then
Set oWork.Worker = oWorkerProvider.GetWorker
Else
Set oWork.Worker = CreateObject("AEWorker.Worker")
End If
'Set the WorkerID property of AEWorker.Worker
'Set the new worker property to the properties
'that have been set for the any other workers
iRetry = 0
oWork.Worker.SetProperties gbLogWorkers, gbEarlyBindServices, _
gbPersistentServices, lAdd
'Add the clsWorker class object which holds a
'reference to the Worker class object to gcWorkers collection
'Use the WorkerID as the key
.WorkerKeys.Add lAdd
gcWorkers.Add oWork, CStr(lAdd)
giWorkerCount = giWorkerCount + 1
iRetry = 0
Set oWork.Worker.QueueMgrRef = New clsQueueDelegator
oWork.Worker.StartPollingQueue
Loop
bAddingWorker = False
End If
End With
SetWorkersOnMachineEnd:
'Update the WorkerCount label in the U/I
'Set connection settings back to local
iResult = oRacReg.SetAutoServerSettings(False, "AEWorkerProvider.WorkerProvider")
If iResult <> 0 Then GoTo SetWorkersOnMachine_RacRegError
If gbShow Then
With frmQueueMgr.lblWorkerCount
.Caption = gcWorkers.Count
.Refresh
End With
End If
'If the WorkerKeys.count = 0 and bRemote is true
'then the clsWorkerMachines class
'object in gcWorkerMachines should be removed
'Don't remove the clsWorkerMachines object representing the
'local machine. Index one is reserved for the local machine.
If oWorkerMachine.WorkerKeys.Count = 0 And bRemote Then
On Error Resume Next
gcWorkerMachines.Remove sMachineName
End If
SetWorkersOnMachine = sErrors
Exit Function
SetWorkersOnMachine_RacRegError:
Err.Raise giCONNECTION_SETTING_FAILED
SetWorkersOnMachineError:
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 for stop test
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
LogEvent giCALL_REJECTED_RETRY, gsNULL_SERVICE_ID
Resume
Else
'We reached our max retries
GoTo SetWorkersOnMachineUnexpectedError
End If
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 oWorkerProvider = oInstancer.Object("AEWorkerProvider.WorkerProvider")
Set oInstancer = Nothing
Resume Next
Case RPC_S_UNKNOWN_AUTHN_TYPE
'Tried to connect to a server that does not support
'specified authentication level. Display message and
'switch to no authentication and try again
Dim s As String
s = sMachineName & gsSEPERATOR & LoadResString(giUSING_NO_AUTHENTICATION)
LogText s, gsNULL_SERVICE_ID
sErrors = s & vbCrLf
iResult = oRacReg.SetAutoServerSettings(True, "AEWorkerProvider.WorkerProvider", , sMachineName, gsProtocol, glAUTHENTICATION_DEFAULT)
Resume
Case giCONNECTION_SETTING_FAILED
sErrors = ReplaceString(LoadResString(giCONNECTION_SETTING_FAILED), gsNAME_TOKEN, LoadResString(giRACREG_ERROR_CODE_OFFSET + iResult))
Err.Raise giNO_WORKERS_CREATED, , sErrors & vbCrLf & LoadResString(giNO_WORKERS_CREATED)
Case Else
SetWorkersOnMachineUnexpectedError:
'There are three cases to respond to if there is an unexpected error
'1- If the error occured while NOT adding a worker it most likely
' occured while removing one. Resume Next to insure that the worker
' is removed from the workers collection.
'2- If we were adding a worker and the worker class was registered local
' log the error, and add it to the sError string, but raise the
' giNO_WORKERS_CREATED error, because the system has a critical problem
' if a local worker can not be created.
'3- If we were adding a worker and the worker class was registered remote
' log the error, and add it to the sError string. Exit procedure so
' that calling procedure can try creating workers on another machine
Dim sSource As String
sSource = Err.Source
sErrors = sErrors & sMachineName & gsSEPERATOR & sSource & gsSEPERATOR & Err.Description & vbCrLf
LogError Err, gsNULL_SERVICE_ID
If Not bAddingWorker Then
Resume Next
Else
If bRemote Then
sErrors = sErrors & vbCrLf & ReplaceString(LoadResString(giCOULD_NOT_CREATE_WORKER_ON_MACHINE), gsNAME_TOKEN, sMachineName)
Resume SetWorkersOnMachineEnd
Else
iResult = oRacReg.SetAutoServerSettings(False, "AEWorkerProvider.WorkerProvider")
sErrors = sErrors & vbCrLf & LoadResString(giCOULD_NOT_CREATE_LOCAL_WORKER)
Err.Raise giNO_WORKERS_CREATED, sSource, sErrors & vbCrLf & LoadResString(giNO_WORKERS_CREATED)
End If
End If
End Select
End Function
Private Function GetUniqueID() As Long
' Returns a unique Long value on each call
Static lID As Long
lID = lID + 1
GetUniqueID = lID
End Function
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/MSCREATE.DIR
View File
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/QMANAGER.ICO
LFS
BIN
View File
Binary file not shown.
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/QUEUE.CLS
+284
View File
@@ -0,0 +1,284 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "Queue"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Description = "APE Job Manager"
Option Explicit
'-------------------------------------------------------------------------
'The Class is public, creatable, multi-use. It is provide as an OLE interface
'for the Client applications to call, adding Service Requests to the Queue
' It implements the IQueue interface
'-------------------------------------------------------------------------
Implements APEInterfaces.IQueue
Public Enum APECallbackNotificationConstants
apeCallbackModeNone = giNO_CALLBACK
apeCallbackModeRegisterEveryRequest = giUSE_PASSED_CALLBACK
apeCallbackModeRegisterOnce = giUSE_DEFAULT_CALLBACK
apeCallbackModeUseRaiseEvent = giRETURN_BY_SYNC_EVENT
End Enum
Private moDefaultCallback As APEInterfaces.IClientCallback 'See DefaultCallback property comments
Private moEventObject As Object
Private mbHaveEventObject As Boolean
'******************
'Public Properties
'******************
Public Property Set IQueue_DefaultCallBack(ByVal oCallback As APEInterfaces.IClientCallback)
Attribute IQueue_DefaultCallBack.VB_Description = "Set the callback object to use when apeCallbackModeRegisterOnce is passed to the Add method as the callback mode."
'-------------------------------------------------------------------------
'Purpose: The property allows a client to set a default
' callback specific to the Queue class object
' that is referenced by the client. By setting
' this property a client can omit the CallBack parameter
' of the Queue.Add method and QueueMgr will use
' the default callback if a call back is required
'In:
' [oCallback]
' Must be a valid callback object having a callback method
'Effects:
' [moDefaultCallback]
' Class level variable is set equal to the passed object
'-------------------------------------------------------------------------
If oCallback Is Nothing Then Err.Raise giINVALID_CALLBACK + vbObjectError, Err.Source, LoadResString(giINVALID_CALLBACK)
Set moDefaultCallback = oCallback
End Property
Public Property Get IQueue_DefaultCallBack() As APEInterfaces.IClientCallback
Set IQueue_DefaultCallBack = moDefaultCallback
End Property
'*****************
'Public Methods
'*****************
Private Function IQueue_Add(ByVal sCommand As String, ByVal sServiceID As String, _
ByVal iCallBackMode As APEInterfaces.APECallbackNotificationConstants, Optional ByVal vData As Variant, _
Optional ByVal CallBack As APEInterfaces.IClientCallback) As Boolean
'-------------------------------------------------------------------------
'Purpose: Called by client Applications to add a Service request to the
' Queue.
'IN:
' [sCommand]
' The string that will be given to a worker with the passed data
' The worker uses this string to determine what OLE Server to
' use as a Service provider. Part of the string is passed to the
' Service provider from the Worker.
' [sServiceID]
' An ID that identifies the service request
' [iCallBackMode]
' Defines if and how data is returned to client calling this function
' [vData]
' (Optional) Variant data that will be given to the Worker also.
' The Worker and the QueueMgr do not know what type of data this is
' The Worker will just pass it the the Service provider
' [Callback]
' (Optional) Callback object. If present, it will be immediately passed
' to the Expediter. The expediter will use it to callback
' delivering results that the Worker gives to it
'Return: True if the Service request was processed
' else returns false.
'Effects:
' The Expediter will get called if a Callback is passed or bUseDefaultCallback
' is true
' [gbBusyAdding]
' is true during this procedure
' [gcQueue]
' will get a clsService class object, storing the Service request
' information.
'Assumptions:
' [gcQueue]
' Is a valid collection object
'-------------------------------------------------------------------------
Dim oService As clsService 'clsService class object which is filled
'with Service request data and added to collection
Dim bDataPresent As Boolean 'Flag that data is present
Dim oCallback As APEInterfaces.IClientCallback 'Callback object that will be passed to Expediter
Dim lCount As Long 'gcQueue.count
On Error GoTo AddError
IQueue_Add = False
'Exit sub if Stopping Queue
If gbStopTest Then Exit Function
gbBusyAdding = True
'Check if the QueueMgr is too busy to process request
If gcQueue.Count >= glMaxQueueSize Then Err.Raise giQUEUE_MGR_IS_BUSY
'Check if data was passed
If IsMissing(vData) Then bDataPresent = False Else bDataPresent = True
'Validate that the Expediter was created successfully
If iCallBackMode <> giNO_CALLBACK Then
If gbFailedToCreateExpediter Then Err.Raise giCOULD_NOT_CREATE_EXPEDITER
End If
'Validate callback object
Select Case iCallBackMode
Case giUSE_PASSED_CALLBACK
If CallBack Is Nothing Then
Err.Raise giINVALID_CALLBACK
Else
Set oCallback = CallBack
End If
Case giUSE_DEFAULT_CALLBACK
If moDefaultCallback Is Nothing Then
Err.Raise giINVALID_CALLBACK
Else
Set oCallback = moDefaultCallback
End If
Case giRETURN_BY_SYNC_EVENT
If Not mbHaveEventObject Then Err.Raise giFIRST_GET_WITHEVENTS_OBJECT
End Select
'Iterate count of this method call
glAddCallCount = glAddCallCount + 1
'Update U/I if form is visible
If gbShow Then frmQueueMgr.lblCount = glAddCallCount
Set oService = New clsService
LogEvent giADD_RECEIVED, sServiceID
'Create the put the Service request values
'in the clsService object
With oService
.ID = sServiceID
.Command = sCommand
.CallBackMode = iCallBackMode
Select Case iCallBackMode
Case giUSE_PASSED_CALLBACK, giUSE_DEFAULT_CALLBACK
Set .CallBack = oCallback
Case giRETURN_BY_SYNC_EVENT
Set .EventObject = moEventObject
End Select
.DataPresent = bDataPresent
'Check what data type vData return is
'in order to determine how to handle it
If bDataPresent Then
Select Case VarType(vData)
Case vbEmpty, vbNull
.Data = Null
Case vbObject, vbError, vbDataObject
Set .Data = vData
Case Else
.Data = vData
End Select
End If
End With
'Add oService to Queue using ID as Key
gcQueue.Add oService, sServiceID
'Display stats
lCount = gcQueue.Count
If gbShow Then frmQueueMgr.lblQueue = lCount
If lCount > glPeakQueueSize Then
glPeakQueueSize = lCount
If gbShow Then frmQueueMgr.lblPeak = glPeakQueueSize
End If
If gbStopTest And Not gbBusyGetServiceRequest And Not gbBusyGetServiceResults Then StopQueue
'Flip the status flag right before the calling client is released
'A worker should not be allowed to take an activity request
'until the client is released. This keeps the the expediter
'from calling the client with Service results before the client
'is released with the return value, the Service ID
oService.Status = giWAITING_FOR_WORKER
Set oService = Nothing
gbBusyAdding = False
IQueue_Add = True
Exit Function
AddError:
Select Case Err.Number
Case giQUEUE_MGR_IS_BUSY
gbBusyAdding = False
Err.Raise Err.Number + vbObjectError, Err.Source, LoadResString(Err.Number)
Exit Function
Case Is > giERROR_THRESHOLD
LogError Err, gsNULL_SERVICE_ID
gbBusyAdding = False
Err.Raise Err.Number + vbObjectError, Err.Source, LoadResString(Err.Number)
Exit Function
Case RPC_E_CALL_REJECTED
'Collision error, the OLE server is busy
Dim iRetry As Integer
Dim il As Integer
Dim ir As Integer
'First check for stop test
If gbStopTest And Not gbBusyGetServiceRequest Then StopQueue: Exit Function
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
LogEvent giCALL_REJECTED_RETRY, sServiceID
Resume
Else
'We reached our max retries
LogError Err, sServiceID
gbBusyAdding = False
Err.Raise Err.Number, Err.Source, Err.Description
End If
Case giCOULD_NOT_CREATE_EXPEDITER
LogError Err, sServiceID
gbBusyAdding = False
Err.Raise giCOULD_NOT_CREATE_EXPEDITER + vbObjectError, Err.Source, LoadResString(giCOULD_NOT_CREATE_EXPEDITER)
Case giFIRST_GET_WITHEVENTS_OBJECT
LogError Err, sServiceID
gbBusyAdding = False
Err.Raise giFIRST_GET_WITHEVENTS_OBJECT + vbObjectError, Err.Source, LoadResString(giFIRST_GET_WITHEVENTS_OBJECT)
Case giINVALID_CALLBACK
LogError Err, sServiceID
gbBusyAdding = False
Err.Raise giINVALID_CALLBACK + vbObjectError, Err.Source, LoadResString(giINVALID_CALLBACK)
Case ERR_OVER_FLOW
LogError Err, sServiceID
If glAddCallCount = glMAX_ID Then glAddCallCount = 0
Resume
Case Else
LogError Err, sServiceID
gbBusyAdding = False
Err.Raise Err.Number, Err.Source, Err.Description
Exit Function
End Select
End Function
Public Function IQueue_GetEventObject() As Object
Attribute IQueue_GetEventObject.VB_Description = "Returns the event source object that a client must respond to when apeCallbackModeUseRaiseEvent is passed to the Add method as the callback mode."
If Not mbHaveEventObject Then
Set moEventObject = goExpediter.GetEventObject
mbHaveEventObject = True
End If
Set IQueue_GetEventObject = moEventObject
End Function
'*******************
'Private methods
'*******************
Private Sub Class_Initialize()
CountInitialize
End Sub
Private Sub Class_Terminate()
CountTerminate
End Sub
build-env/VisualStudio6/Common/Tools/APE/Source/Aequeue/QUEUEMGR.CLS
+723
View File
@@ -0,0 +1,723 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'False
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
END
Attribute VB_Name = "QueueMgr"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Description = "APE Job Manager"
Option Explicit
'-------------------------------------------------------------------------
'This public multi-use class provides the OLE interface for the APE Manager
'or another application designed to be the Manager
' It implements the IQueueManager interface
'-------------------------------------------------------------------------
Implements APEInterfaces.IQueueManager
'***********************
'Public Properties
'***********************
Private Property Get IQueueManager_IsIdle() As Boolean
'-------------------------------------------------------------------------
'Purpose: Returns True if the Queue is idle.
'-------------------------------------------------------------------------
If gcQueue.Count = 0 Then
Dim oWorker As clsWorker
IQueueManager_IsIdle = True
For Each oWorker In gcWorkers
If oWorker.Busy Then
IQueueManager_IsIdle = False
Exit For
End If
Next
Else
IQueueManager_IsIdle = False
End If
End Property
Public Property Let IQueueManager_MaxQueueSize(ByVal lMax As Long)
Attribute IQueueManager_MaxQueueSize.VB_Description = "Sets or returns the value that controls the size of the Queue that causes Service Requests to be rejected."
'-------------------------------------------------------------------------
'Purpose: MaxQueueSize property determines the maximum amount
' of ServiceRequests that will be allowed to back up
'Effects: [glMax] becomes value of parameter
'-------------------------------------------------------------------------
glMaxQueueSize = lMax
End Property
Public Property Get IQueueManager_MaxQueueSize() As Long
IQueueManager_MaxQueueSize = glMaxQueueSize
End Property
Public Property Let IQueueManager_ShowQueue(ByVal bShow As Boolean)
Attribute IQueueManager_ShowQueue.VB_Description = "Determines whether the AEQueueMgr shows a form."
'-------------------------------------------------------------------------
'Purpose: Show property determines whether or not a form
' is displayed while QueueMgr is loaded
'Effects: [gbShow] becomes value of parameter
' If parameter is true frmQueueMgr is show, else form
' is Unloaded.
'-------------------------------------------------------------------------
If Not gbShow = bShow Then
gbShow = bShow
If bShow Then
With frmQueueMgr
.Show
.lblCount.Caption = glAddCallCount
.lblPeak.Caption = glPeakQueueSize
.lblQueue.Caption = gcQueue.Count
.lblWorkerCount.Caption = gcWorkers.Count
End With
Else
Unload frmQueueMgr
End If
End If
End Property
Public Property Get IQueueManager_ShowQueue() As Boolean
IQueueManager_ShowQueue = gbShow
End Property
Public Property Let IQueueManager_LogQueue(ByVal bLog As Boolean)
Attribute IQueueManager_LogQueue.VB_Description = "Determines if the AEQueueMgr logs its events and errors to the AELogger.Logger object."
'-------------------------------------------------------------------------
'Purpose: If log is true create logger class object and log Services
'Effects: [gbLog] becomes value of parameter
' [goLogger] is set to a new AELogger.Logger object if parameter
' is true. If false goLogger is destroyed
'-------------------------------------------------------------------------
On Error GoTo LogQueueError
If Not gbLog = bLog Then
gbLog = bLog
If bLog Then
Set goLogger = CreateObject("AELogger.Logger")
Else
Set goLogger = Nothing
End If
End If
Exit Property
LogQueueError:
Select Case Err.Number
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 goLogger = oInstancer.Object("AELogger.Logger")
Set oInstancer = Nothing
Resume Next
Case Else
Err.Raise Err.Number, Err.Source, Err.Description
End Select
End Property
Public Property Get IQueueManager_LogQueue() As Boolean
IQueueManager_LogQueue = gbLog
End Property
'********************
'Worker Properties
'********************
Public Property Let IQueueManager_LogWorkers(ByVal bLog As Boolean)
Attribute IQueueManager_LogWorkers.VB_Description = "Sets the value that is used to set the Log property of AEWorker.Worker objects."
'-------------------------------------------------------------------------
'Purpose: To set the Log property of all the Workers
'Effects:
' [gbLogWorkers]
' becomes equal to the passed parameter
'Assumes: There is a collection of one or more valid Worker objects
'-------------------------------------------------------------------------
'If the property setting actually
'changes the current property pass
'the property change to all the Workers
Dim oWork As clsWorker
If Not bLog = gbLogWorkers Then
For Each oWork In gcWorkers
oWork.Worker.Log = bLog
Next oWork
gbLogWorkers = bLog
End If
End Property
Public Property Get IQueueManager_LogWorkers() As Boolean
IQueueManager_LogWorkers = gbLogWorkers
End Property
Public Property Let IQueueManager_PersistentServices(ByVal bPersistent As Boolean)
Attribute IQueueManager_PersistentServices.VB_Description = "Sets the value that is used to set the PersistentServices property of AEWorker.Worker objects."
'-------------------------------------------------------------------------
'Purpose: To set the PersistentServices property of all the Workers
'Effects:
' [gbPersistentServices]
' becomes equal to the passed parameter
'Assumes: There is a collection of one or more valid Worker objects
'-------------------------------------------------------------------------
'If the property setting actually
'changes the current property pass
'the property change to all the Workers
Dim oWork As clsWorker
If Not bPersistent = gbPersistentServices Then
For Each oWork In gcWorkers
oWork.Worker.PersistentServices = bPersistent
Next oWork
gbPersistentServices = bPersistent
End If
End Property
Public Property Get IQueueManager_PersistentServices() As Boolean
IQueueManager_PersistentServices = gbPersistentServices
End Property
Public Property Let IQueueManager_EarlyBindServices(ByVal bEarlyBind As Boolean)
Attribute IQueueManager_EarlyBindServices.VB_Description = "Sets the value that is used to set the EarlyBindServices property of AEWorker.Worker objects."
'-------------------------------------------------------------------------
'Purpose: To set the EarlyBindServices property of all the Workers
'Effects:
' [gbEarlyBindServices]
' becomes equal to the passed parameter
'Assumes: There is a collection of one or more valid Worker objects
'-------------------------------------------------------------------------
'If the property setting actually
'changes the current property pass
'the property change to all the Workers
Dim oWork As clsWorker
If Not bEarlyBind = gbEarlyBindServices Then
For Each oWork In gcWorkers
oWork.Worker.EarlyBindServices = bEarlyBind
Next oWork
gbEarlyBindServices = bEarlyBind
End If
End Property
Public Property Get IQueueManager_EarlyBindServices() As Boolean
IQueueManager_EarlyBindServices = gbEarlyBindServices
End Property
'********************
'Expediter Properties
'********************
Public Property Let IQueueManager_ShowExpediter(ByVal bShow As Boolean)
Attribute IQueueManager_ShowExpediter.VB_Description = "Sets the Show property of the AEExpediter.Expediter object."
'-------------------------------------------------------------------------
'Purpose: To set the Show property of the Expediter
'Effects:
' [gbShowExpediter]
' becomes equal to the passed parameter
'Assumes:
' [goExpediter]
' Is a valid AEExpediter.Expediter object
'-------------------------------------------------------------------------
'If the property setting actually
'changes the current property pass
'the property change to the expediter
If Not bShow = gbShowExpediter Then
goExpediter.Show = bShow
gbShowExpediter = bShow
End If
End Property
Public Property Get IQueueManager_ShowExpediter() As Boolean
IQueueManager_ShowExpediter = gbShowExpediter
End Property
Public Property Let IQueueManager_LogExpediter(ByVal bLog As Boolean)
Attribute IQueueManager_LogExpediter.VB_Description = "Set the Log property of the AEExpediter.Expediter object."
'-------------------------------------------------------------------------
'Purpose: To set the Log property of the Expediter
'Effects:
' [gbLogExpediter]
' becomes equal to the passed parameter
'Assumes:
' [goExpediter]
' Is a valid AEExpediter.Expediter object
'-------------------------------------------------------------------------
'If the property setting actually
'changes the current property pass
'the property change to the expediter
If Not bLog = gbLogExpediter Then
goExpediter.Log = bLog
gbLogExpediter = bLog
End If
End Property
Public Property Get IQueueManager_LogExpediter() As Boolean
IQueueManager_LogExpediter = gbLogExpediter
End Property
'****************************
'Public Methods
'****************************
Public Sub IQueueManager_SetProperties(ByVal bShow As Boolean, Optional ByVal bLog As Variant)
Attribute IQueueManager_SetProperties.VB_Description = "Sets all of the AEQueueMgr.QueueMgr related properties in one method call."
'-------------------------------------------------------------------------
'Purpose: To set the QueueMgr properties in one method call
'Effects: Sets the following properties to parameter values
' ShowQueue, LogQueue, WorkerQuantity
'-------------------------------------------------------------------------
With Me
.IQueueManager_ShowQueue = bShow
If Not IsMissing(bLog) Then .IQueueManager_LogQueue = bLog
End With
End Sub
Public Sub IQueueManager_SetWorkerProperties(ByVal bLog As Boolean, Optional ByVal bEarlyBindServices As Variant, _
Optional ByVal bPersistentServices As Variant)
Attribute IQueueManager_SetWorkerProperties.VB_Description = "Sets all of the AEWorker.Worker related properties on one method call."
'-------------------------------------------------------------------------
'Purpose: To set the Worker properties in one method call
'Effects: Sets the following properties to parameter values
' ShowWorkers, LogWorkers, EarlyBindServices, PersistentServices
'-------------------------------------------------------------------------
Dim oWork As clsWorker
gbLogWorkers = bLog
If Not IsMissing(bEarlyBindServices) Then gbEarlyBindServices = bEarlyBindServices
If Not IsMissing(bPersistentServices) Then IQueueManager_PersistentServices = bPersistentServices
For Each oWork In gcWorkers
oWork.Worker.SetProperties gbLogWorkers, gbEarlyBindServices, gbPersistentServices
Next oWork
End Sub
Public Sub IQueueManager_SetExpediterProperties(ByVal bShow As Boolean, Optional ByVal bLog As Variant)
Attribute IQueueManager_SetExpediterProperties.VB_Description = "Sets all of the AEExpediter.Expediter related properties in one method call."
'-------------------------------------------------------------------------
'Purpose: To set the Expediter properties in one method call
'Effects: Sets the following properties to parameter values
' ShowExpediter, LogExpediter
'-------------------------------------------------------------------------
gbShowExpediter = bShow
If Not IsMissing(bLog) Then gbLogExpediter = bLog
goExpediter.SetProperties gbShowExpediter, gbLogExpediter
End Sub
Public Sub IQueueManager_SetConnectionProperties(ByVal bUseDCOM As Boolean, Optional ByVal sProtocol As Variant, _
Optional ByVal lAuthentication As Variant)
Attribute IQueueManager_SetConnectionProperties.VB_Description = "Sets the connection parameters to be used when creating remote AEWorker.Worker objects."
'-------------------------------------------------------------------------
'Purpose: To set the Connection Settings that the QueueMgr will use
' to connect to remote Workers
'In:
' [bUseDCOM]
' If true workers will be created using DCOM instead of
' Remote Automation.
' [sProtocol]
' Protocol sequence to use when connecting to remote objects
' [lAuthentication]
' Authentication level to use
'Effects:
' [gbUseDCOM]
' becomes equal to bUseDCOM parameter
' [gsProtocol]
' becomes equal to sProtocol parameter
' [glAuthentication]
' becomes equal to lAuthentication parameter
'-------------------------------------------------------------------------
Dim iVarType As Integer 'Variant type code of lAuthentication
gbUseDCOM = bUseDCOM
If Not IsMissing(sProtocol) Then
If VarType(sProtocol) = vbString Then gsProtocol = sProtocol
End If
If Not IsMissing(lAuthentication) Then
iVarType = VarType(lAuthentication)
If iVarType = vbLong Or iVarType = vbInteger Or iVarType = vbDouble Or iVarType = vbSingle Then
glAuthentication = lAuthentication
End If
End If
End Sub
Public Function IQueueManager_CreateWorkers(ByVal bRemoteWorkers As Boolean, Optional ByVal lWorkerQuantity As Variant, _
Optional ByVal lWorkersPerMachine As Variant, Optional ByVal vaMachineList As Variant, _
Optional ByVal bUseLocalMachine As Variant) As String
Attribute IQueueManager_CreateWorkers.VB_Description = "Creates AEWorker.Worker objects. Returns a string that describes any errors that occurred."
'-------------------------------------------------------------------------
'Purpose: Sets the settings for remote workers. These settings provide
' The QueueMgr the information needed to create Workers on several
' remote machines rather than just the local one.
'IN:
' [bRemoteWorkers]
' If true, the QueueMgr will create Workers on remote machines.
' If false, the QueueMgr will only create Workers on the local machine.
' [lWorkerQuantity]
' The total number of Workers to be created.
' [lWorkersPerMachine]
' A variant long specifing the maximum allowed number of Workers
' to create on a single machine.
' [vaMachineList]
' A string array, providing the list of machine names
' to create the workers on. If this is not a valid
' array of strings it will be treated like no machine
' names were specified
' [bUseLocalMachine]
' If true, include local machine in list of remote machine names
'Return: String to display to user and print to log file. Will contain
' any error information and the total number of workers created
'-------------------------------------------------------------------------
Static stbUseDCOM As Boolean 'Last DCom automation setting used
Static stsProtocol As String 'Last Automation protocol setting used
Static stlAuthentication As Long 'Last Automation Authentication setting used
Dim sResult As String 'Result of SetWorkersOnMachine function
Dim sErrors As String 'String with error descriptions to return for
'display to user
Dim oWorkerMachine As clsWorkerMachines 'Object in gcWorkerMachines collection
'that stores how many workers are instanciated
'on a particular machine
Dim lUB As Long 'Ubound of passed array
Dim bListExists As Boolean 'True if a array of machine names exists
Dim bInList As Boolean 'If true the Machine Name is in the passed array
Dim i As Integer 'For...Next loop counter
Dim lAdd As Long 'Number of Workers to add on machine
Dim lNumOnMach As Long 'Number of workers on a machine
Dim iVarType As Integer 'Variant data type of a parameter
On Error GoTo CreateWorkersError
'Validate the parameters
'validate lWorkerQuantity
iVarType = VarType(lWorkerQuantity)
If Not (iVarType = vbLong Or iVarType = vbInteger Or iVarType = vbSingle Or iVarType = vbDouble) Then
Err.Raise giINVALID_PARAMETER, , LoadResString(giINVALID_PARAMETER)
ElseIf lWorkerQuantity <= 0 Then
'Make sure at least one worker is created
lWorkerQuantity = 1
End If
If bRemoteWorkers Then
'validate vaMachineList
iVarType = VarType(vaMachineList)
If (iVarType = vbArray + vbString) Or (iVarType = vbArray + vbVariant) Then
On Error Resume Next
lUB = UBound(vaMachineList)
If Err.Number <> ERR_SUBSCRIPT_OUT_OF_RANGE Then
bListExists = True
End If
On Error GoTo CreateWorkersError
End If
'validate lworkerspermachine
iVarType = VarType(lWorkersPerMachine)
If Not (iVarType = vbLong Or iVarType = vbInteger Or iVarType = vbSingle Or iVarType = vbDouble) Then
Err.Raise giINVALID_PARAMETER, , LoadResString(giINVALID_PARAMETER)
ElseIf lWorkersPerMachine <= 0 Then
lWorkersPerMachine = 1
End If
'validate bUseLocalMachine
On Error Resume Next
bUseLocalMachine = CBool(bUseLocalMachine)
If Err.Number = ERR_TYPE_MISMATCH Then
On Error GoTo CreateWorkersError
Err.Raise giINVALID_PARAMETER, , LoadResString(giINVALID_PARAMETER)
Else
On Error GoTo CreateWorkersError
End If
End If
'First destroy all workers that can not be used any more
'If connection settings have been changed or if bRemoteWorkers
'is false all Workers on remote machines must be destroyed
If (Not bRemoteWorkers) Or (stbUseDCOM <> gbUseDCOM) Or (stsProtocol <> gsProtocol) Or (stlAuthentication <> glAuthentication) Then
'Reset the Last Connection setting static variables
stbUseDCOM = gbUseDCOM
stsProtocol = gsProtocol
stlAuthentication = glAuthentication
'Destroy all remote Workers
For Each oWorkerMachine In gcWorkerMachines
If oWorkerMachine.Remote Then
sResult = SetWorkersOnMachine(True, oWorkerMachine.MachineName, 0)
sErrors = sErrors & sResult
End If
Next
Else
'If we did not destroy all workers on remote machines
'destroy workers that are on machines that are not
'in the passed list of remote worker machines
'Check if the machine names currently in gcWorkerMachines
'are in the passed array
For Each oWorkerMachine In gcWorkerMachines
If oWorkerMachine.Remote Then
bInList = False
If bListExists Then
For i = 0 To lUB
If vaMachineList(i) = oWorkerMachine.MachineName Then
bInList = True
Exit For
End If
Next
End If
If Not bInList Then
sResult = SetWorkersOnMachine(True, oWorkerMachine.MachineName, 0)
sErrors = sErrors & sResult
End If
End If
Next
End If
'See if Workers on local machine need destroyed
If bRemoteWorkers Then
If Not bUseLocalMachine Then
sResult = SetWorkersOnMachine(False, "", 0)
sErrors = sErrors & sResult
End If
End If
'Create Workers
If Not bRemoteWorkers Then
'Just create all workers on local machine
sResult = SetWorkersOnMachine(False, "", CLng(lWorkerQuantity))
sErrors = sErrors & sResult
Else
'Now loop through machine name list and add workers
'to each machine until giWorkerCount equals
'lWorkerQuantity or the end of the machine list is
'reached
If giWorkerCount <= lWorkerQuantity Then
'First create workers on local machine
If bUseLocalMachine Then
'Get the number of workers currently on this machine
lNumOnMach = gcWorkerMachines.Item(1).WorkerKeys.Count
'Set number of Workers to be on current machine
lAdd = lWorkersPerMachine
If lAdd > (lWorkerQuantity + lNumOnMach) - giWorkerCount Then lAdd = (lWorkerQuantity + lNumOnMach) - giWorkerCount
sResult = SetWorkersOnMachine(False, "", lAdd)
sErrors = sErrors & sResult
End If
If bListExists Then
Do Until (i > lUB Or giWorkerCount = lWorkerQuantity)
On Error Resume Next
'Get the number of workers currently on this machine
Set oWorkerMachine = gcWorkerMachines.Item(vaMachineList(i))
If Err.Number = ERR_INVALID_PROCEDURE_CALL Then
lNumOnMach = 0
Else
lNumOnMach = oWorkerMachine.WorkerKeys.Count
End If
On Error GoTo CreateWorkersError
'Set number of Workers to be on current machine
lAdd = lWorkersPerMachine
If lAdd > (lWorkerQuantity + lNumOnMach) - giWorkerCount Then lAdd = (lWorkerQuantity + lNumOnMach) - giWorkerCount
sResult = SetWorkersOnMachine(True, CStr(vaMachineList(i)), lAdd)
sErrors = sErrors & sResult
i = i + 1
Loop
End If
Else
'There may be too many workers, so destroy workers to
'make the right count
If bListExists Then
i = lUB
Do While i >= 0
On Error Resume Next
'Get the number of workers currently on this machine
Set oWorkerMachine = gcWorkerMachines.Item(vaMachineList(i))
If Err.Number = ERR_INVALID_PROCEDURE_CALL Then
lNumOnMach = 0
Else
lNumOnMach = oWorkerMachine.WorkerKeys.Count
End If
On Error GoTo CreateWorkersError
If lNumOnMach > 0 Then
lAdd = 0
If lNumOnMach > (giWorkerCount - lWorkerQuantity) Then lAdd = lNumOnMach - (giWorkerCount - lWorkerQuantity)
sResult = SetWorkersOnMachine(True, CStr(vaMachineList(i)), lAdd)
sErrors = sErrors & sResult
End If
i = i - 1
Loop
End If
'if there are still too many workers
'reduce the number of workers on the local machine
If giWorkerCount > lWorkerQuantity Then
lNumOnMach = gcWorkerMachines.Item(1).WorkerKeys.Count
lAdd = 0
If lNumOnMach > (giWorkerCount - lWorkerQuantity) Then lAdd = lNumOnMach - (giWorkerCount - lWorkerQuantity)
sResult = SetWorkersOnMachine(False, "", lAdd)
sErrors = sErrors & sResult
End If
End If
End If
'Check if any workers were created and raise error if none were created
If giWorkerCount < lWorkerQuantity Then
If giWorkerCount = 0 Then
Err.Raise giNO_WORKERS_CREATED, , sErrors & vbCrLf & LoadResString(giNO_WORKERS_CREATED)
Else
sErrors = sErrors & vbCrLf & ReplaceString(LoadResString(giONLY_N_WORKERS_CREATED), gsNUMBER_TOKEN, CStr(giWorkerCount))
End If
Else
sErrors = sErrors & vbCrLf & LoadResString(giALL_WORKERS_CREATED)
End If
IQueueManager_CreateWorkers = sErrors
Exit Function
CreateWorkersError:
Select Case Err.Number
Case Is > giERROR_THRESHOLD
Err.Raise Err.Number + vbObjectError, Err.Source, Err.Description
Case Else
Err.Raise Err.Number, Err.Source, Err.Description
End Select
End Function
Public Function IQueueManager_GetRemoteLoggerCollection() As Collection
Attribute IQueueManager_GetRemoteLoggerCollection.VB_Description = "Returns a collection of remote AELogger.Logger objects that were created by remote AEWorker.Worker objects."
'-------------------------------------------------------------------------
'Purpose: Returnse the collection of loggers created on the same
' machines as remote Workers
'Assumes:
' [gcWorkerMachines]
' a valid collection of clsWorkerMachines object
' [clsWorkerMachines]
' If .Remote is true .WorkerKeys.Count is > 0
'-------------------------------------------------------------------------
Dim cRemoteLoggers As Collection 'Collection to return
Dim oWorkerMachine As clsWorkerMachines 'Object representing each Worker machine
Dim oLogger As APEInterfaces.ILogger 'Valid logger object or nothing
Set cRemoteLoggers = New Collection
For Each oWorkerMachine In gcWorkerMachines
With oWorkerMachine
If .Remote Then
Dim oWork As clsWorker
Set oWork = gcWorkers.Item(CStr(.WorkerKeys(1)))
Set oLogger = oWork.Worker.GetLogger
If Not oLogger Is Nothing Then
cRemoteLoggers.Add oLogger
End If
End If
End With
Next
If cRemoteLoggers.Count = 0 Then Set cRemoteLoggers = Nothing
Set IQueueManager_GetRemoteLoggerCollection = cRemoteLoggers
End Function
Public Sub IQueueManager_LoadServiceObject(ByVal ServiceLibClass As String, ByVal vServiceConfiguration As Variant)
Attribute IQueueManager_LoadServiceObject.VB_Description = "Causes all created AEWorker.Worker objects to create an object whose ProgID matches ServiceLibClass."
'-------------------------------------------------------------------------
'Purpose: Purpose is to call LoadServiceObject method in each
' instanciated worker. It is ignored if gbPeristentServices
' is false
'Assumes:
' [gcWorkers]
' Is a collection of valid AEWorker.Worker objects
'-------------------------------------------------------------------------
Dim oWork As clsWorker
If gbPersistentServices Then
For Each oWork In gcWorkers
oWork.Worker.LoadServiceObject ServiceLibClass, vServiceConfiguration
Next oWork
End If
End Sub
Public Sub IQueueManager_StopTest()
Attribute IQueueManager_StopTest.VB_Description = "Causes the AEQueueMgr to stop processing Service Requests and to empty its queue."
'-------------------------------------------------------------------------
'Purpose: Stops all Queue Managers processes
'Effects:
' May call StopQueue
' [gbStopTest]
' Becomes true
'-------------------------------------------------------------------------
'Call this to halt the Queue Manager and the Expediter
goExpediter.StopTest
gbStopTest = True
If Not gbBusyAdding And Not gbBusyGetServiceRequest Then StopQueue
Exit Sub
End Sub
Public Sub IQueueManager_StartTest()
Attribute IQueueManager_StartTest.VB_Description = "Prepares the AEQueueMgr to process Service Requests after StopTest has been called."
'-------------------------------------------------------------------------
'Purpose: Call this to allow processing of Services after calling StopTest
'Effects:
' Resets U/I to look like QueueMgr just started
' [gbStopTest]
' Becomes False
'-------------------------------------------------------------------------
Dim oWork As clsWorker
Dim iRetry As Integer
On Error GoTo StartTestError
'Reset stats
gbStopTest = False
With goExpediter
iRetry = 0
'.QueueMgrRef must be set before StartTest is called
Set .QueueMgrRef = New clsQueueDelegator
.StartTest
End With
If gbShow Then
DisplayStatus ""
glAddCallCount = 0
glPeakQueueSize = 0
With frmQueueMgr
.lblCount.Caption = 0
.lblPeak.Caption = 0
.lblQueue.Caption = 0
.lblWorkerCount.Caption = gcWorkers.Count
.lblCount.Refresh
.lblPeak.Refresh
.lblQueue.Refresh
.lblWorkerCount.Refresh
End With
End If
Exit Sub
StartTestError:
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 for stop test
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
LogEvent giCALL_REJECTED_RETRY, gsNULL_SERVICE_ID
Resume
Else
'We reached our max retries
LogError Err, gsNULL_SERVICE_ID
Resume Next
End If
Case Else
Err.Raise Err.Number, Err.Source, Err.Description
End Select
End Sub
'********************
'Private Procedures
'********************
Private Sub Class_Initialize()
CountInitialize
End Sub
Private Sub Class_Terminate()
CountTerminate
End Sub