VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "Service" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = True Attribute VB_Description = "APE Service" Option Explicit Implements APEInterfaces.IService Private Const msJetDBName = "APETest.mdb" ' Name of Jet database used for database tests ' Text of "DRIVER" specifications of connect string for supported database types Private Const msAccessDriver = "Microsoft Access Driver (*.mdb)" Private Const msSQLServerDriver = "SQL Server" Private Const miMinQueryRetryDelay As Integer = 20 ' Min delay (ms) between retries of a query that failed due to a locking contention Private Const miMaxQueryRetryDelay As Integer = 100 ' Max delay (ms) between retries of a query that failed due to a locking contention Private moWorkspace As Object ' The workspace for the connection Private moConnection As Object ' The connection established by calling the Initialize method Private moDatabase As DAO.Database ' The database used for DAO operations Private mvServiceConfiguration As Variant ' Service configuration options (array) Private mbConnectionOpen As Boolean ' Flag indicating that there is a connection opened in the Initialize procedure Private mbLogDatabaseEvents As Boolean Private mbLogMTSTransactions As Boolean Private mbShowMTSTransactions As Boolean Private msServiceID As String Private mDBType As ape_DbServerOptions ' Type of database that the service connects to ' Handles for the ODBC API calls Private mhEnvironment As Long Private mhConnection As Long Private mhStatement As Long Const msERROR_SOURCE As String = "AEService" Public Sub Execute(ByRef sServiceID As String, ByRef sCommand As String, Optional ByRef vServiceData As Variant, Optional ByRef vReturn As Variant) Attribute Execute.VB_Description = "AEWorker.Worker objects call this method when using late binding." '------------------------------------------------------------------------- 'Purpose: ' Provides an interface for late binding. Late binding is only provided ' for test comparison. Other custom services should only use the implemented ' interface. '------------------------------------------------------------------------- Dim bDataMissing As Boolean Dim bReturnMissing As Boolean bDataMissing = IsMissing(vServiceData) bReturnMissing = IsMissing(vReturn) If bDataMissing And bReturnMissing Then IService_Execute sServiceID, sCommand ElseIf bReturnMissing Then IService_Execute sServiceID, sCommand, vServiceData ElseIf bDataMissing Then IService_Execute sServiceID, sCommand, , vReturn Else IService_Execute sServiceID, sCommand, vServiceData, vReturn End If End Sub Public Sub Initialize(vServiceConfiguration As Variant) '------------------------------------------------------------------------- 'Purpose: ' Provides an interface for late binding. Late binding is only provided ' for test comparison. Other custom services should only use the implemented ' interface. '------------------------------------------------------------------------- IService_Initialize vServiceConfiguration End Sub Private Sub IService_Execute(sServiceID As String, sCommand As String, Optional vServiceData As Variant, Optional vReturn As Variant) '------------------------------------------------------------------------- 'Purpose: ' In response to the data it receives, it may return data of different ' sizes are types and/or sleep or burn processor cycles for a certain ' amount of time. 'In: ' [sCommand] ' A string the represents what this procedure should do. It is intended ' be used to case and call an appropriate procedure in response if this ' was a real solution service provider. This object expects either ' "UseProcessor" or "DontUserProcessor". ' [vServiceData] ' This object expects a variant array or variant collection in which ' the elements of the array or collection specify how much data to ' return, what type of data to return, and how long to wait before ' releasing the calling worker. 'Out: ' [vReturn] ' This could be a variant array or collection of any specified size ' it will be returned by the calling worker to the client or the ' expediter '------------------------------------------------------------------------- 'sCommand What to do. Ex: "Method" 'vServiceData The data needed to carrry out sCommand. Dim iLensCommand As Integer Dim iChar As Integer Dim iLastChar As Integer Dim lEndTicks As Long Dim lRecordNumRows As Long Dim lRecordRowSize As Long Dim lRecordTaskDuration As Long, lRecordSleepPeriod As Long Dim lRecordContainerType As Long Dim sRecordDatabaseQuery As String Dim rsService As Recordset Dim s As String Dim i As Integer Dim v() As Variant msServiceID = sServiceID On Error GoTo Service_ExecuteError If Not IsMissing(vServiceData) Then 'Are we using a Varriant Array or Collection? If VarType(vServiceData) = (vbArray + vbVariant) Then 'It's an array lRecordNumRows = vServiceData(giRECORD_NUMROWS) lRecordRowSize = vServiceData(giRECORD_ROWSIZE) lRecordTaskDuration = vServiceData(giRECORD_TASK_DURATION) lRecordSleepPeriod = vServiceData(giRECORD_SLEEP_PERIOD) lRecordContainerType = vServiceData(giRECORD_CONTAINER_TYPE) sRecordDatabaseQuery = vServiceData(giRECORD_DATABASE_QUERY) mvServiceConfiguration = vServiceData(giRECORD_SERVICE_CONFIGURATION) Else 'It's a collection lRecordNumRows = vServiceData.Item(CStr(giRECORD_NUMROWS)) lRecordRowSize = vServiceData.Item(CStr(giRECORD_ROWSIZE)) lRecordTaskDuration = vServiceData.Item(CStr(giRECORD_TASK_DURATION)) lRecordSleepPeriod = vServiceData.Item(CStr(giRECORD_SLEEP_PERIOD)) lRecordContainerType = vServiceData.Item(CStr(giRECORD_CONTAINER_TYPE)) sRecordDatabaseQuery = vServiceData.Item(CStr(giRECORD_DATABASE_QUERY)) mvServiceConfiguration = vServiceData.Item(CStr(giRECORD_SERVICE_CONFIGURATION)) End If 'Do we need to do anything? If lRecordTaskDuration < 0 Or lRecordTaskDuration > glMAX_DURATION Then Err.Raise giBAD_DURATION End If Dim iCommand As Integer iCommand = CInt(sCommand) If (iCommand And giMASK_USE_CPU_TASK) Then 'If use processor always If lRecordTaskDuration > 0 Then lEndTicks = GetTickCount() + lRecordTaskDuration Do While lEndTicks > GetTickCount() 'Using Cycles Loop End If If lRecordSleepPeriod > 0 Then Sleep lRecordSleepPeriod End If End If If (iCommand And giMASK_USE_DB_TASK) Then 'If a database task On Error GoTo 0 ' Do not trap MTS errors or PerformQuery errors. If (iCommand And giMASK_WRITE_MTS_TRANSACTION) <> 0 Then WriteMTSTransaction mvServiceConfiguration(ape_conConnectionString), mvServiceConfiguration(ape_conConnectionOption) Else ' Perform query PerformQuery sRecordDatabaseQuery End If On Error GoTo Service_ExecuteError End If If (Not IsMissing(vReturn)) And lRecordContainerType <> giCONTAINER_TYPE_NULL And lRecordNumRows <> 0 And lRecordRowSize <> 0 Then 'Return something Select Case lRecordContainerType Case giCONTAINER_TYPE_VARRAY s = Space(lRecordRowSize) ReDim v(lRecordNumRows - 1) As Variant For i = 0 To lRecordNumRows - 1 v(i) = s Next i vReturn = v Case giCONTAINER_TYPE_VCOLLECTION Set vReturn = New Collection s = Space(lRecordRowSize) For i = 1 To lRecordNumRows vReturn.Add s Next i Case giCONTAINER_TYPE_RECORDSET 'Not yet implemented Set vReturn = Nothing Case Else 'Some unknown ContainterTypeValue Err.Raise giBAD_DATA_TYPE End Select End If Exit Sub Service_ExecuteError: Dim lErrorNumber As Long Dim sErrorDescription As String lErrorNumber = Err.Number sErrorDescription = Err.Description Select Case lErrorNumber Case ERR_TYPE_MISMATCH, ERR_OVER_FLOW 'vServiceData contained a bad data type. Raise an appliction defined error. Err.Raise giBAD_DATA, msERROR_SOURCE, NestedErrorDescription(giERROR_EXECUTE_METHOD, LoadResString(giBAD_DATA)) Case giBAD_DURATION 'They wanted to sleep more than glMAX_DURATION Err.Raise lErrorNumber, msERROR_SOURCE, NestedErrorDescription(giERROR_EXECUTE_METHOD, _ ReplaceString(LoadResString(giBAD_DURATION), gsNUMBER_TOKEN, CStr(glMAX_DURATION))) Case Is > giERROR_THRESHOLD 'Application defined error. Since this is the only public method 'all errors raised there will be returned to the calling program. Err.Raise lErrorNumber + vbObjectError, msERROR_SOURCE, NestedErrorDescription(giERROR_EXECUTE_METHOD, sErrorDescription) Case Else 'VB error Err.Raise lErrorNumber, msERROR_SOURCE, NestedErrorDescription(giERROR_EXECUTE_METHOD, sErrorDescription) End Select End Sub Public Sub IService_Initialize(vServiceConfiguration As Variant) ' If a connection is already open, then close it (object is being reinitialized) If Not IsEmpty(mvServiceConfiguration) Then If (mvServiceConfiguration(ape_conConnectionOption) <> vServiceConfiguration(ape_conConnectionOption) Or _ mvServiceConfiguration(ape_conConnectionString) <> vServiceConfiguration(ape_conConnectionString)) Then Debug.Assert mbConnectionOpen Select Case mvServiceConfiguration(ape_conConnectionOption) Case ape_idcODBC SQLFreeHandle SQL_HANDLE_STMT, mhStatement SQLEndTran SQL_HANDLE_DBC, mhConnection, SQL_COMMIT SQLDisconnect mhConnection Case Else If Not moConnection Is Nothing Then moConnection.Close Set moConnection = Nothing End If End Select mbConnectionOpen = False End If End If mvServiceConfiguration = vServiceConfiguration ' Open a connection if a connection string is specified If Not (mbConnectionOpen Or IsEmpty(mvServiceConfiguration(ape_conConnectionString))) Then OpenServiceConnection mbConnectionOpen = True End If mbLogMTSTransactions = mvServiceConfiguration(ape_conLogMTSTransactions) If mbShowMTSTransactions <> mvServiceConfiguration(ape_conShowMTSTransactions) Then mbShowMTSTransactions = mvServiceConfiguration(ape_conShowMTSTransactions) If mbShowMTSTransactions Then frmService.Show Else Unload frmService End If End If mbLogDatabaseEvents = mvServiceConfiguration(ape_conLogDatabaseEvents) frmService.Reset End Sub Private Sub ExecuteADOCommand(sQuery As String) Dim conConnection As ADODB.Connection Dim rsRecordset As New ADODB.Recordset Dim s As String Dim lErrorNumber As Long Dim sa() As String Dim iRetries As Integer iRetries = 0 On Error GoTo ADOTransactionError Set conConnection = moConnection ' Get array of queries If GetArrayFromDelimited(sQuery, sa, "//") Then TryAgain: conConnection.BeginTrans Dim i As Integer For i = LBound(sa) To UBound(sa) If Left(sa(i), 6) = "SELECT" Then ' Only SELECT queries return records rsRecordset.Open sa(i), conConnection, adOpenKeyset ' Default CursorType (adOpenForwardOnly) doesn't support MoveLast rsRecordset.MoveFirst Do While Not rsRecordset.EOF rsRecordset.MoveNext Loop rsRecordset.Close Else conConnection.Execute sa(i) End If Next conConnection.CommitTrans End If Exit Sub ADOTransactionError: ' If the error is due to a locking contention, roll back the transaction and try again If Err.Number = -2147467259 And iRetries < giMAX_ALLOWED_RETRIES Then conConnection.RollbackTrans iRetries = iRetries + 1 Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd ' Randomize the delay to avoid repeated contentions Resume TryAgain End If Dim sErrorDescription As String sErrorDescription = Err.Description lErrorNumber = Err.Number conConnection.RollbackTrans Err.Raise lErrorNumber, , sErrorDescription End Sub Private Sub ExecuteRDOCommand(sQuery As String) Dim conConnection As rdoConnection Dim rsResultset As rdoResultset Dim s As String Dim lErrorNumber As Long Dim sa() As String Dim iRetries As Integer iRetries = 0 On Error GoTo RDOTransactionError Set conConnection = moConnection If GetArrayFromDelimited(sQuery, sa, "//") Then TryAgain: conConnection.BeginTrans Dim i As Integer For i = LBound(sa) To UBound(sa) If Left(sa(i), 6) = "SELECT" Then ' Only SELECT queries return records Set rsResultset = conConnection.OpenResultset(sa(i), dbOpenDynaset) rsResultset.MoveFirst Do While Not rsResultset.EOF rsResultset.MoveNext Loop rsResultset.Close Else conConnection.Execute sa(i) End If Next conConnection.CommitTrans End If Exit Sub RDOTransactionError: ' If the error is due to a locking contention, roll back the transaction and try again If Err.Number = 40002 And iRetries < giMAX_ALLOWED_RETRIES Then ' First make sure the cause really is a locking contention ' Determine which database-specific error number to check for Select Case mDBType Case ape_idsJet lErrorNumber = -1102 Case ape_idsSqlServer lErrorNumber = 1205 Case Else Err.Raise E_NOTIMPL End Select Dim RDOErr As RDO.rdoError For Each RDOErr In rdoEngine.rdoErrors If RDOErr.Number = lErrorNumber Then conConnection.RollbackTrans iRetries = iRetries + 1 Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd ' Randomize the delay to avoid repeated contentions Resume TryAgain End If Next End If Dim sErrorDescription As String sErrorDescription = Err.Description lErrorNumber = Err.Number conConnection.RollbackTrans Err.Raise lErrorNumber, , sErrorDescription End Sub Private Sub ExecuteDAOCommand(sQuery As String) Dim rsRecordset As DAO.Recordset Dim s As String Dim lErrorNumber As Long Dim sa() As String Dim iRetries As Integer iRetries = 0 On Error GoTo DAOTransactionError If GetArrayFromDelimited(sQuery, sa, "//") Then TryAgain: moWorkspace.BeginTrans Dim i As Integer For i = LBound(sa) To UBound(sa) If Left(sa(i), 6) = "SELECT" Then ' Only SELECT queries return records Set rsRecordset = moDatabase.OpenRecordset(sa(i), dbOpenDynaset, dbSQLPassThrough) rsRecordset.MoveFirst Do While Not rsRecordset.EOF rsRecordset.MoveNext Loop rsRecordset.Close Else moDatabase.Execute sa(i), dbSQLPassThrough End If Next moWorkspace.CommitTrans End If Exit Sub DAOTransactionError: ' If the error is due to a locking contention, roll back the transaction and try again If Err.Number = 3146 And iRetries < giMAX_ALLOWED_RETRIES Then ' First make sure the cause really is a locking contention ' Determine which database-specific error number to check for Select Case mDBType Case ape_idsJet lErrorNumber = -1102 Case ape_idsSqlServer lErrorNumber = 1205 Case Else Err.Raise E_NOTIMPL End Select Dim DAOErr As DAO.Error For Each DAOErr In DBEngine.Errors If DAOErr.Number = lErrorNumber Then moWorkspace.Rollback iRetries = iRetries + 1 Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd ' Randomize the delay to avoid repeated contentions Resume TryAgain End If Next End If Dim sErrorDescription As String sErrorDescription = Err.Description lErrorNumber = Err.Number moWorkspace.Rollback Err.Raise lErrorNumber, , sErrorDescription End Sub Private Sub ExecuteODBCAPICommand(sQuery As String) Dim lErrorNumber As Long Dim sa() As String Dim iRetries As Integer iRetries = 0 On Error GoTo ODBCAPITransactionError If GetArrayFromDelimited(sQuery, sa, "//") Then TryAgain: Dim i As Integer For i = LBound(sa) To UBound(sa) If Left(sa(i), 6) = "SELECT" Then ' Only SELECT queries return records If Not ODBCAPICallSuccessful(SQLExecDirect(mhStatement, sa(i), Len(sa(i)))) Then Err.Raise ErrorExecuteQuery, , LoadResString(ErrorExecuteQuery) End If Dim bEOF As Boolean Select Case SQLFetchScroll(mhStatement, SQL_FETCH_FIRST, 0) Case SQL_NO_DATA bEOF = True Case SQL_SUCCESS, SQL_SUCCESS_WITH_INFO bEOF = False Case Else SQLCloseCursor mhStatement Err.Raise ErrorFetchRecord, , LoadResString(ErrorFetchRecord) End Select Do While Not bEOF Select Case SQLFetchScroll(mhStatement, SQL_FETCH_NEXT, 0) Case SQL_NO_DATA bEOF = True Case SQL_SUCCESS, SQL_SUCCESS_WITH_INFO bEOF = False Case Else SQLCloseCursor mhStatement Err.Raise ErrorFetchRecord, , LoadResString(ErrorFetchRecord) End Select Loop SQLCloseCursor mhStatement Else If Not ODBCAPICallSuccessful(SQLExecDirect(mhStatement, sa(i), Len(sa(i)))) Then Err.Raise ErrorExecuteQuery, , LoadResString(ErrorExecuteQuery) End If End If Next If Not ODBCAPICallSuccessful(SQLEndTran(SQL_HANDLE_DBC, mhConnection, SQL_COMMIT)) Then Err.Raise ErrorEndTransaction, , LoadResString(ErrorEndTransaction) End If End If Exit Sub ODBCAPITransactionError: ' If the error is due to a resource deadlock, roll back the transaction and try again If Err.Number = ErrorExecuteQuery And iRetries < giMAX_ALLOWED_RETRIES Then Dim iRecNum As Integer, iTextLen As Integer Dim sSQLState As String * 5, sMsgText As String * 1 Dim lNativeErrorPtr As Long iRecNum = 1 Do While ODBCAPICallSuccessful(SQLGetDiagRec(SQL_HANDLE_STMT, mhStatement, iRecNum, sSQLState, lNativeErrorPtr, _ sMsgText, 0, iTextLen)) If sSQLState = "40001" Then SQLEndTran SQL_HANDLE_DBC, mhConnection, SQL_ROLLBACK iRetries = iRetries + 1 Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd ' Randomize the delay to avoid repeated contentions Resume TryAgain End If iRecNum = iRecNum + 1 Loop End If Dim sErrorDescription As String sErrorDescription = Err.Description lErrorNumber = Err.Number SQLEndTran SQL_HANDLE_DBC, mhConnection, SQL_ROLLBACK Err.Raise lErrorNumber, , sErrorDescription End Sub Private Sub PerformQuery(sRecordDatabaseQuery As String) ' Performs the database queries Dim bConnectionOpenedInExecute As Boolean On Error GoTo PerformQueryError bConnectionOpenedInExecute = False If mbLogDatabaseEvents Then LogEvent giBEGIN_DATABASE_QUERY, msServiceID End If If Not mbConnectionOpen Then On Error GoTo 0 ' Do not trap OpenServiceConnection errors. OpenServiceConnection On Error GoTo PerformQueryError bConnectionOpenedInExecute = True End If ParseQuery sRecordDatabaseQuery If mvServiceConfiguration(ape_conConnectionOption) = ape_idcODBC Then ExecuteODBCAPICommand (sRecordDatabaseQuery) If bConnectionOpenedInExecute Then If Not ODBCAPICallSuccessful(SQLFreeHandle(SQL_HANDLE_STMT, mhStatement)) Then Err.Raise ErrorFreeHandle, , LoadResString(ErrorFreeHandle) End If If Not ODBCAPICallSuccessful(SQLEndTran(SQL_HANDLE_DBC, mhConnection, SQL_COMMIT)) Then Err.Raise ErrorEndTransaction, , LoadResString(ErrorEndTransaction) End If If Not ODBCAPICallSuccessful(SQLDisconnect(mhConnection)) Then Err.Raise ErrorDisconnectDriver, , LoadResString(ErrorDisconnectDriver) End If End If Else Select Case mvServiceConfiguration(ape_conConnectionOption) Case ape_idcADO ExecuteADOCommand (sRecordDatabaseQuery) Case ape_idcRDO ExecuteRDOCommand (sRecordDatabaseQuery) Case ape_idcDAO ExecuteDAOCommand (sRecordDatabaseQuery) Case Else Err.Raise E_NOTIMPL End Select If bConnectionOpenedInExecute And Not moConnection Is Nothing Then moConnection.Close bConnectionOpenedInExecute = False End If End If If mbLogDatabaseEvents Then LogEvent giEND_DATABASE_QUERY, msServiceID End If Exit Sub PerformQueryError: Dim lErrorNumber As Long Dim sErrorDescription As String lErrorNumber = Err.Number sErrorDescription = Err.Description If bConnectionOpenedInExecute Then Select Case mvServiceConfiguration(ape_conConnectionOption) Case ape_idcODBC SQLFreeHandle SQL_HANDLE_STMT, mhStatement SQLEndTran SQL_HANDLE_DBC, mhConnection, SQL_COMMIT SQLDisconnect mhConnection Case Else If Not moConnection Is Nothing Then moConnection.Close End If End Select End If Err.Raise lErrorNumber, msERROR_SOURCE, NestedErrorDescription(giERROR_PERFORM_DATABASE_QUERY, sErrorDescription) End Sub Private Sub WriteMTSTransaction(ByVal sConnect As String, ByVal eConnectOptions As ape_DbConnectionOptions) ' Create the appropriate MoveMoney object Dim objMoveMoney As APEInterfaces.IMTSMoveMoney Const miMinQueryRetryDelay As Integer = 20 ' Min delay (ms) between retries of a query that failed due to a locking contention Const miMaxQueryRetryDelay As Integer = 100 ' Max delay (ms) between retries of a query that failed due to a locking contention Const miMAX_ALLOWED_RETRIES As Integer = 500 ' Maximum number of retries of a query that failed due to a locking contention Dim iTransferRetries As Integer iTransferRetries = 0 On Error GoTo ErrorHandler Set objMoveMoney = CreateObject("AEMTSSvc.MoveMoney") If mbLogMTSTransactions Then LogEvent giBEGIN_MTS_TRANSACTION, msServiceID End If Const iMAX_ACCOUNT_NO = 1000 ' Highest account number (1 is presumed to be the lowest) Dim lFromAccount As Long, lToAccount As Long lFromAccount = 1 + Int(iMAX_ACCOUNT_NO * Rnd) lToAccount = 1 + Int(iMAX_ACCOUNT_NO * Rnd) objMoveMoney.Transfer sConnect, eConnectOptions, lFromAccount, lToAccount, 1 If mbLogMTSTransactions Then LogEvent giEND_MTS_TRANSACTION_SUCCEEDED, msServiceID End If If mbShowMTSTransactions Then frmService.MTSResults True End If Exit Sub ErrorHandler: ' If the error is due to a locking contention, try again If iTransferRetries < miMAX_ALLOWED_RETRIES Then Dim bRetry As Boolean bRetry = False Select Case eConnectOptions Case ape_idcADO bRetry = (Err.Number = -2147467259) Case ape_idcDAO If Err.Number = 3146 Then ' First make sure the cause really is a locking contention Dim DAOErr As DAO.Error For Each DAOErr In DBEngine.Errors If DAOErr.Number = 1205 Then ' 1205 = SQL Server record locking contention bRetry = True End If Next End If Case ape_idcRDO If Err.Number = 40002 Then ' First make sure the cause really is a locking contention Dim RDOErr As RDO.rdoError For Each RDOErr In rdoEngine.rdoErrors If RDOErr.Number = 1205 Then ' 1205 = SQL Server record locking contention bRetry = True End If Next End If Case ape_idcODBC bRetry = (Err.Number = ErrorResourceDeadlock) End Select If bRetry Then iTransferRetries = iTransferRetries + 1 Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd ' Randomize the delay to avoid repeated contentions DoEvents Resume End If End If Dim lErrorNumber As Long Dim sErrorSource As String Dim sErrorDescription As String lErrorNumber = Err.Number sErrorSource = Err.Source If Err.Number = ERR_CANT_CREATE_OBJECT Then sErrorDescription = LoadResString(giERROR_CREATE_MTS_OBJECT) Else sErrorDescription = Err.Description End If If mbLogMTSTransactions Then LogEvent giEND_MTS_TRANSACTION_FAILED, msServiceID End If If mbShowMTSTransactions Then frmService.MTSResults False End If Err.Raise lErrorNumber, sErrorSource, sErrorDescription End Sub Private Sub OpenServiceConnection() Debug.Assert Not IsEmpty(mvServiceConfiguration) ' mvServiceConfiguration must be set before calling this method ' Make the current directory the app path (usually starts out being the Windows System[32] directory) which is where the ' Jet database is stored. On Error GoTo ErrorHandler ChDir App.Path ChDrive App.Path ' Set the database type If InStr(mvServiceConfiguration(ape_conConnectionString), "DRIVER={" & msSQLServerDriver & "}") > 0 Then mDBType = ape_idsSqlServer ElseIf InStr(mvServiceConfiguration(ape_conConnectionString), "DRIVER={" & msAccessDriver & "}") > 0 Then mDBType = ape_idsJet Else Err.Raise E_NOTIMPL End If Select Case mvServiceConfiguration(ape_conConnectionOption) Case ape_idcADO Set moConnection = New ADODB.Connection moConnection.Open mvServiceConfiguration(ape_conConnectionString) Case ape_idcRDO Set moWorkspace = rdoEngine.rdoEnvironments(0) Set moConnection = moWorkspace.OpenConnection("", rdDriverNoPrompt, , _ mvServiceConfiguration(ape_conConnectionString)) Case ape_idcDAO Set moWorkspace = DBEngine.Workspaces(0) ' Special handling is required for Jet databases If mDBType = ape_idsJet Then Set moDatabase = DBEngine.OpenDatabase(msJetDBName, False, False) Else Set moDatabase = DBEngine.OpenDatabase("", False, False, "ODBC;" & mvServiceConfiguration(ape_conConnectionString)) End If Case ape_idcODBC Dim iConnectLength As Integer If Not ODBCAPICallSuccessful(SQLDriverConnect(mhConnection, 0, mvServiceConfiguration(ape_conConnectionString), _ LenB(mvServiceConfiguration(ape_conConnectionString)), vbNullString, 0, iConnectLength, SQL_DRIVER_NOPROMPT)) Then Err.Raise ErrorConnectDriver, , LoadResString(ErrorConnectDriver) End If If Not ODBCAPICallSuccessful(SQLAllocHandle(SQL_HANDLE_STMT, mhConnection, mhStatement)) Then SQLDisconnect mhConnection Err.Raise ErrorAllocateHandle, , LoadResString(ErrorAllocateHandle) End If If Not ODBCAPICallSuccessful(SQLSetStmtAttrLong(mhStatement, SQL_CURSOR_TYPE, SQL_CURSOR_STATIC, 0)) Then SQLFreeHandle SQL_HANDLE_STMT, mhStatement SQLDisconnect mhConnection Err.Raise ErrorSetAttribute, , LoadResString(ErrorSetAttribute) End If Case Else Err.Raise E_NOTIMPL End Select Exit Sub ErrorHandler: Err.Raise Err.Number, msERROR_SOURCE, NestedErrorDescription(giERROR_OPENING_SERVICE_CONNECTION, Err.Description) End Sub Private Sub Class_Initialize() Randomize mbConnectionOpen = False mbLogMTSTransactions = False mbShowMTSTransactions = False If Not ODBCAPICallSuccessful(SQLAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE, mhEnvironment)) Then Err.Raise ErrorAllocateHandle, , LoadResString(ErrorAllocateHandle) End If If Not ODBCAPICallSuccessful(SQLSetEnvAttrLong(mhEnvironment, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC3, 0)) Then SQLFreeHandle SQL_HANDLE_ENV, mhEnvironment Err.Raise ErrorSetAttribute, , LoadResString(ErrorSetAttribute) End If If Not ODBCAPICallSuccessful(SQLAllocHandle(SQL_HANDLE_DBC, mhEnvironment, mhConnection)) Then SQLFreeHandle SQL_HANDLE_ENV, mhEnvironment Err.Raise ErrorAllocateHandle, , LoadResString(ErrorAllocateHandle) End If End Sub Private Sub Class_Terminate() On Error Resume Next Unload frmService If mbConnectionOpen Then Select Case mvServiceConfiguration(ape_conConnectionOption) Case ape_idcODBC SQLDisconnect mhConnection Case ape_idcDAO moDatabase.Close Case Else moConnection.Close End Select End If SQLFreeHandle SQL_HANDLE_DBC, mhConnection SQLFreeHandle SQL_HANDLE_ENV, mhEnvironment End Sub