'***********************************************************************
'* Class : db_Eclipse.TagGroup
'*
'* Purpose : Insert, Update, and Delete Eclipse TAG_GROUP records
'*
'* References : Microsoft ActiveX Data Objects 2.0 Type Library (msado20.tlb)
'* Microsoft Transaction Server Type Library (mtxas.dll)
'* Transaction Context Type Library (txctx.dll)
'* SecurityGate 1.0 Type Library (SecurityGate.dll)
'* Baycore (baycorewrap.dll)
'* Registry (registry.dll)
'* Strings (strings.dll)
'* Microsoft Scripting Runtime (scrrun.dll)
'*
'* Revision : 1.0.0 03/30/1999 James Bischoff
'* Initial release
'***********************************************************************
Option Explicit
Private Const mcstrBaseRegistryKey = "HKEY_LOCAL_MACHINE\SOFTWARE\UpperBay\Eclipse\1.0"
Private Const mcstrAppName As String = "EclipseDataAccess"
Private Const mcstrClassName As String = "db_Eclipse->TagGroup"
'Transaction server automatically calls
' ObjectControl_Activate
' ObjectControl_Deactivate
' ObjectControl_CanBePooled
Implements ObjectControl
Private mobjContext As MTxAS.ObjectContext
Private mblnValidated As Boolean
Private mobjADOConnection As ADODB.Connection
Private mobjADOInsertCommand As ADODB.Command
Private mobjADOUpdateCommand As ADODB.Command
Private mobjADODeleteCommand As ADODB.Command
Private mstrLastDBSiteCode As String
'***********************************************************************
'* Class and MTX Generic Procedures
'* This code is the same for all data access classes
'***********************************************************************
'***********************************************************************
'* Sub : Class_Initialize()
'* Purpose : Only called the first time the object is created.
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Sub Class_Initialize()
On Error GoTo ErrorHandler
Const cstrMethodName As String = "Class_Initialize"
SetupLocalMessenger
SetupGlobalValues mcstrBaseRegistryKey, mcstrAppName
SendDebug mcstrClassName, cstrMethodName, "Initialized Class"
Exit Sub
ErrorHandler:
SendError mcstrClassName, cstrMethodName, Err.Source & " - " & Err.Description
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'***********************************************************************
'* Sub : Class_Terminate()
'* Purpose : Only called when the object is destroyed.
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Sub Class_Terminate()
On Error GoTo ErrorHandler
Const cstrMethodName As String = "Class_Terminate"
SendDebug mcstrClassName, cstrMethodName, "Start"
SendDebug mcstrClassName, cstrMethodName, "Destroy ADO Command Objects"
Set mobjADOInsertCommand = Nothing
Set mobjADOUpdateCommand = Nothing
Set mobjADODeleteCommand = Nothing
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Sub
ErrorHandler:
SendError mcstrClassName, cstrMethodName, Err.Source & " - " & Err.Description
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'***********************************************************************
'* Sub : ObjectControl_Activate()
'* Purpose : MTX calls this sub when this object is created or recycled
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Sub ObjectControl_Activate()
On Error GoTo ErrorHandler
Const cstrMethodName As String = "ObjectControl_Activate"
SendDebug mcstrClassName, cstrMethodName, "Start"
Set mobjContext = GetObjectContext()
If mobjContext Is Nothing Then
SendDebug mcstrClassName, cstrMethodName, "Could NOT get Context Object"
SendDebug mcstrClassName, cstrMethodName, "Create Stand Alone ADO Connection Object"
Set mobjADOConnection = New ADODB.Connection
Else
SendDebug mcstrClassName, cstrMethodName, "Got Context Object"
SendDebug mcstrClassName, cstrMethodName, "Create MTX ADO Connection Object"
Set mobjADOConnection = mobjContext.CreateInstance("ADODB.Connection")
End If
mblnValidated = False
mstrLastDBSiteCode = ""
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Sub
ErrorHandler:
SendError mcstrClassName, cstrMethodName, Err.Source & " - " & Err.Description
SetAbort mobjContext, mcstrClassName, cstrMethodName
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'***********************************************************************
'* Sub : ObjectControl_CanBePooled()
'* Purpose : MTX calls this sub after calling ObjectControl_Deactivate
'* to see if the object shold be recycled or destroyed.
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Function ObjectControl_CanBePooled() As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "ObjectControl_CanBePooled"
SendDebug mcstrClassName, cstrMethodName, "Start"
SendDebug mcstrClassName, cstrMethodName, "Set Return True"
ObjectControl_CanBePooled = True
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
SendError mcstrClassName, cstrMethodName, Err.Source & " - " & Err.Description
SetAbort mobjContext, mcstrClassName, cstrMethodName
Err.Raise Err.Number, Err.Source, Err.Description
End Function
'***********************************************************************
'* Sub : ObjectControl_Deactivate()
'* Purpose : MTX calls this sub after receiving a SetComplete or
'* SetAbort via the context object.
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Sub ObjectControl_Deactivate()
On Error GoTo ErrorHandler
Const cstrMethodName As String = "ObjectControl_Deactivate"
SendDebug mcstrClassName, cstrMethodName, "Start"
DestroyADOConnection mobjADOConnection, mcstrClassName, cstrMethodName
SendDebug mcstrClassName, cstrMethodName, "Destroy Context Object"
Set mobjContext = Nothing
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Sub
ErrorHandler:
SendError mcstrClassName, cstrMethodName, Err.Source & " - " & Err.Description
SendDebug mcstrClassName, cstrMethodName, "Destroy Context Object"
Set mobjContext = Nothing
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'***********************************************************************
'* Generic Class Procedures
'* This code is generic for all data access classes
'***********************************************************************
'***********************************************************************
'* Function : SubmitBatch()
'* Purpose : Submit an updateable recordset for batch update.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function SubmitBatch( _
ByVal strDBSiteCode As String, _
ByRef vntADORecordset As Variant, _
ByRef vntStatus() As Variant, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "SubmitBatch"
SendDebug mcstrClassName, cstrMethodName, "Start"
SubmitBatch = True
If Not SubmitRSBatch( _
mobjContext, _
strDBSiteCode, _
vntADORecordset, _
vntStatus, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "SubmitRSBatch Failure Abort"
SubmitBatch = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Else
SetComplete mobjContext, mcstrClassName, cstrMethodName
End If
Exit Function
ErrorHandler:
SubmitBatch = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
SetAbort mobjContext, mcstrClassName, cstrMethodName
End Function
'***********************************************************************
'* Function : ExecuteSQL()
'* Purpose : Execute any SQL and return an ADO Recordset.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function ExecuteSQL( _
ByVal strDBSiteCode As String, _
ByVal strSQL As String, _
ByVal blnReadonly As Boolean, _
ByRef vntADORecordset As Variant, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "ExecuteSQL"
Dim objADORecordset As ADODB.Recordset
SendDebug mcstrClassName, cstrMethodName, "Start"
ExecuteSQL = True
If Not GetADORecordSet( _
mobjContext, _
strDBSiteCode, _
strSQL, _
blnReadonly, _
objADORecordset, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "GetADORecordSet Failure Abort"
ExecuteSQL = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
End If
Set vntADORecordset = objADORecordset
Set objADORecordset = Nothing
SetComplete mobjContext, mcstrClassName, cstrMethodName
Exit Function
ErrorHandler:
ExecuteSQL = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
Set objADORecordset = Nothing
SetAbort mobjContext, mcstrClassName, cstrMethodName
End Function
'***********************************************************************
'* Class Specific Procedures
'* This code is specific to each data access classe
'*
'* All classes have the following generic functions:
'*
'* Add
'* Update
'* Load
'* Delete
'* GetByAny
'* CreateEmptyRS
'*
'***********************************************************************
'***********************************************************************
'* Function : Add()
'* Purpose : Add a record
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function Add( _
ByVal strDBSiteCode As String, _
ByVal strTagGroupName As String, _
ByVal strcreator As String, _
ByVal strTagGroupDesc As String, _
ByVal strTagGroupTypeName As Variant, _
ByVal strDeptName As Variant, _
ByVal strTagGroupClassName As Variant, _
ByVal lngRetention As Variant, _
ByVal dtmCreationDate As Variant, _
ByVal dtmExpirationDate As Variant, _
ByVal strOffLineFlag As String, _
ByVal strCollSysName As Variant, _
ByRef vntRecordsAffected As Variant, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "Add"
Dim objADOConnection As ADODB.Connection
Dim objADOCommand As ADODB.Command
Dim strSQL
Dim strADOConnectString As String
Dim lngRecordsAffected As Long
SendDebug mcstrClassName, cstrMethodName, "Start"
Add = True
If Not mblnValidated Then
If Not ValidateWriteAccessBySite( _
mcstrClassName, _
cstrMethodName, _
strDBSiteCode, _
mobjContext, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "Security Failure Abort"
Add = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Exit Function
End If
mblnValidated = True
End If
If mobjADOInsertCommand Is Nothing Then
strSQL = "insert into tag_group ( " & _
" tag_group_name, " & _
" creator, " & _
" Tag_Group_Desc, " & _
" Tag_Group_Type_Name, " & _
" Dept_Name, " & _
" Tag_Group_Class_Name, " & _
" Retention, " & _
" Creation_Date, " & _
" Expiration_Date, " & _
" Off_Line_Flag, " & _
" Coll_Sys_Name) " & _
"values ( " & _
" ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? )"
Set mobjADOInsertCommand = New ADODB.Command
With mobjADOInsertCommand
.CommandText = strSQL
.CommandType = adCmdText
.Prepared = True
SendDebug mcstrClassName, cstrMethodName, "Setup ADO Command Object Parameters"
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 80)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
.Parameters.Append .CreateParameter(, adInteger, adParamInput)
.Parameters.Append .CreateParameter(, adDBTimeStamp, adParamInput)
.Parameters.Append .CreateParameter(, adDBTimeStamp, adParamInput)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 1)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
End With
End If
If Not OpenADOConnection( _
strDBSiteCode, _
mstrLastDBSiteCode, _
mobjADOConnection, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "OpenADOConnection Failure Abort"
Add = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Exit Function
End If
If mobjADOInsertCommand.ActiveConnection Is Nothing Then
SendDebug mcstrClassName, cstrMethodName, "Establish ADO Command Connection"
Set mobjADOInsertCommand.ActiveConnection = mobjADOConnection
End If
SendDebug mcstrClassName, cstrMethodName, "Execute ADO Command"
mobjADOInsertCommand.Execute _
lngRecordsAffected, _
Array(strTagGroupName, _
strcreator, _
strTagGroupDesc, _
strTagGroupTypeName, _
strDeptName, _
strTagGroupClassName, _
lngRetention, _
dtmCreationDate, _
dtmExpirationDate, _
strOffLineFlag, _
strCollSysName), _
adExecuteNoRecords
vntRecordsAffected = lngRecordsAffected
SetComplete mobjContext, mcstrClassName, cstrMethodName
Exit Function
ErrorHandler:
Add = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
SetAbort mobjContext, mcstrClassName, cstrMethodName
End Function
'***********************************************************************
'* Function : Update()
'* Purpose : Update a record by the table's primary key.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function Update( _
ByVal strDBSiteCode As String, _
ByVal strTagGroupName As String, _
ByVal strcreator As String, _
ByVal strTagGroupDesc As String, _
ByVal strTagGroupTypeName As Variant, _
ByVal strDeptName As Variant, _
ByVal strTagGroupClassName As Variant, _
ByVal lngRetention As Variant, _
ByVal dtmCreationDate As Variant, _
ByVal dtmExpirationDate As Variant, _
ByVal strOffLineFlag As String, _
ByVal strCollSysName As Variant, _
ByRef vntRecordsAffected As Variant, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "Update"
Dim strSQL
Dim lngRecordsAffected As Long
SendDebug mcstrClassName, cstrMethodName, "Start"
Update = True
If Not mblnValidated Then
If Not ValidateWriteAccessBySite( _
mcstrClassName, _
cstrMethodName, _
strDBSiteCode, _
mobjContext, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "Security Failure Abort"
Update = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Exit Function
End If
mblnValidated = True
End If
If mobjADOUpdateCommand Is Nothing Then
strSQL = "update tag_group set " & _
" creator = ?, " & _
" Tag_Group_Desc = ?, " & _
" Tag_Group_Type_Name = ?, " & _
" Dept_Name = ?, " & _
" Tag_Group_Class_Name = ?, " & _
" Retention = ?, " & _
" Creation_Date = ?, " & _
" Expiration_Date = ?, " & _
" Off_Line_Flag = ?, " & _
" Coll_Sys_Name = ? " & _
"where " & _
" tag_group_name = ? "
Set mobjADOUpdateCommand = New ADODB.Command
With mobjADOUpdateCommand
.CommandText = strSQL
.CommandType = adCmdText
.Prepared = True
SendDebug mcstrClassName, cstrMethodName, "Setup ADO Command Object Parameters"
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 80)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
.Parameters.Append .CreateParameter(, adInteger, adParamInput)
.Parameters.Append .CreateParameter(, adDBTimeStamp, adParamInput)
.Parameters.Append .CreateParameter(, adDBTimeStamp, adParamInput)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 1)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
End With
End If
If Not OpenADOConnection( _
strDBSiteCode, _
mstrLastDBSiteCode, _
mobjADOConnection, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "OpenADOConnection Failure Abort"
Update = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Exit Function
End If
If mobjADOUpdateCommand.ActiveConnection Is Nothing Then
SendDebug mcstrClassName, cstrMethodName, "Establish ADO Command Connection"
Set mobjADOUpdateCommand.ActiveConnection = mobjADOConnection
End If
SendDebug mcstrClassName, cstrMethodName, "Execute ADO Command"
mobjADOUpdateCommand.Execute _
lngRecordsAffected, _
Array(strcreator, _
strTagGroupDesc, _
strTagGroupTypeName, _
strDeptName, _
strTagGroupClassName, _
lngRetention, _
dtmCreationDate, _
dtmExpirationDate, _
strOffLineFlag, _
strCollSysName, _
strTagGroupName), _
adExecuteNoRecords
vntRecordsAffected = lngRecordsAffected
SetComplete mobjContext, mcstrClassName, cstrMethodName
Exit Function
ErrorHandler:
Update = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
SetAbort mobjContext, mcstrClassName, cstrMethodName
End Function
'***********************************************************************
'* Function : Load()
'* Purpose : Update or Insert a record by the table's primary key.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function Load( _
ByVal strDBSiteCode As String, _
ByVal strTagGroupName As String, _
ByVal strcreator As String, _
ByVal strTagGroupDesc As String, _
ByVal strTagGroupTypeName As Variant, _
ByVal strDeptName As Variant, _
ByVal strTagGroupClassName As Variant, _
ByVal lngRetention As Variant, _
ByVal dtmCreationDate As Variant, _
ByVal dtmExpirationDate As Variant, _
ByVal strOffLineFlag As String, _
ByVal strCollSysName As Variant, _
ByRef vntRecordsAffected As Variant, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "Load"
SendDebug mcstrClassName, cstrMethodName, "Start"
Load = True
If Not Update( _
strDBSiteCode, _
strTagGroupName, _
strcreator, _
strTagGroupDesc, _
strTagGroupTypeName, _
strDeptName, _
strTagGroupClassName, _
lngRetention, _
dtmCreationDate, _
dtmExpirationDate, _
strOffLineFlag, _
strCollSysName, _
vntRecordsAffected, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "Update Failure Abort"
Load = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Exit Function
End If
If vntRecordsAffected = 0 Then
If Not Add( _
strDBSiteCode, _
strTagGroupName, _
strcreator, _
strTagGroupDesc, _
strTagGroupTypeName, _
strDeptName, _
strTagGroupClassName, _
lngRetention, _
dtmCreationDate, _
dtmExpirationDate, _
strOffLineFlag, _
strCollSysName, _
vntRecordsAffected, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "Add Failure Abort"
Load = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Exit Function
End If
End If
SetComplete mobjContext, mcstrClassName, cstrMethodName
Exit Function
ErrorHandler:
Load = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
SetAbort mobjContext, mcstrClassName, cstrMethodName
End Function
'***********************************************************************
'* Function : Delete()
'* Purpose : Delete a record by the table's primary key.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function Delete( _
ByVal strDBSiteCode As String, _
ByVal strTagGroupName As String, _
ByRef vntRecordsAffected As Variant, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "Delete"
Dim strSQL
Dim lngRecordsAffected As Long
SendDebug mcstrClassName, cstrMethodName, "Start"
Delete = True
If Not mblnValidated Then
If Not ValidateWriteAccessBySite( _
mcstrClassName, _
cstrMethodName, _
strDBSiteCode, _
mobjContext, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "Security Failure Abort"
Delete = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Exit Function
End If
mblnValidated = True
End If
If mobjADODeleteCommand Is Nothing Then
strSQL = "delete " & _
"from " & _
" tag_group " & _
"where " & _
" tag_group_name = ? "
Set mobjADODeleteCommand = New ADODB.Command
With mobjADODeleteCommand
.CommandText = strSQL
.CommandType = adCmdText
.Prepared = True
SendDebug mcstrClassName, cstrMethodName, "Setup ADO Command Object Parameters"
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, 30)
End With
End If
If Not OpenADOConnection( _
strDBSiteCode, _
mstrLastDBSiteCode, _
mobjADOConnection, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "OpenADOConnection Failure Abort"
Delete = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Exit Function
End If
If mobjADODeleteCommand.ActiveConnection Is Nothing Then
SendDebug mcstrClassName, cstrMethodName, "Establish ADO Command Connection"
Set mobjADODeleteCommand.ActiveConnection = mobjADOConnection
End If
SendDebug mcstrClassName, cstrMethodName, "Execute ADO Command"
mobjADODeleteCommand.Execute _
lngRecordsAffected, _
Array(strTagGroupName), _
adExecuteNoRecords
vntRecordsAffected = lngRecordsAffected
SetComplete mobjContext, mcstrClassName, cstrMethodName
Exit Function
ErrorHandler:
Delete = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
SetAbort mobjContext, mcstrClassName, cstrMethodName
End Function
'***********************************************************************
'* Function : GetByAny()
'* Purpose : Get a record by any field.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetByAny( _
ByVal strDBSiteCode As String, _
ByVal blnReadonly As Boolean, _
ByRef vntADORecordset As Variant, _
ByRef vntErrorMessage As Variant, _
Optional ByVal strColumns As String = "*", _
Optional ByVal strOrderBy As String = "", _
Optional ByVal strTagGroupNameMask As String = "", _
Optional ByVal strcreatorMask As String = "", _
Optional ByVal strTagGroupDescMask As String = "", _
Optional ByVal strTagGroupTypeNameMask As String = "", _
Optional ByVal strDeptNameMask As String = "", _
Optional ByVal strTagGroupClassNameMask As String = "", _
Optional ByVal strRetentionMask As String = "", _
Optional ByVal strCreationDateMask As String = "", _
Optional ByVal strExpirationDateMask As String = "", _
Optional ByVal strOffLineFlagMask As String = "", _
Optional ByVal strCollSysNameMask As String = "") _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "GetByAny"
Dim strSQL As String
Dim strWhere As String
Dim objADORecordset As ADODB.Recordset
SendDebug mcstrClassName, cstrMethodName, "Start"
GetByAny = True
If Len(strColumns) = 0 Then
strColumns = "*"
End If
strSQL = "select " & _
strColumns & " " & _
"from " & _
" tag_group"
strWhere = ""
If Not AddWhereSegment( _
"tag_group_name", _
strTagGroupNameMask, _
DbTypeString, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Not AddWhereSegment( _
"creator", _
strcreatorMask, _
DbTypeString, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Not AddWhereSegment( _
"tag_group_desc", _
strTagGroupDescMask, _
DbTypeString, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Not AddWhereSegment( _
"tag_group_type_name", _
strTagGroupTypeNameMask, _
DbTypeString, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Not AddWhereSegment( _
"dept_name", _
strDeptNameMask, _
DbTypeString, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Not AddWhereSegment( _
"tag_group_class_name", _
strTagGroupClassNameMask, _
DbTypeString, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Not AddWhereSegment( _
"Retention", _
strRetentionMask, _
DbTypeNumber, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Not AddWhereSegment( _
"Creation_Date", _
strCreationDateMask, _
dbTypeDate, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Not AddWhereSegment( _
"Expiration_Date", _
strExpirationDateMask, _
dbTypeDate, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Not AddWhereSegment( _
"Off_Line_Flag", _
strOffLineFlagMask, _
DbTypeString, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Not AddWhereSegment( _
"Coll_Sys_name", _
strCollSysNameMask, _
DbTypeString, _
strWhere, _
vntErrorMessage) Then
GetByAny = False
Exit Function
End If
If Len(strWhere) > 0 Then
strSQL = strSQL & " where " & strWhere
End If
If Len(strOrderBy) > 0 Then
strSQL = strSQL & " order by " & strOrderBy
End If
If Not GetADORecordSet( _
mobjContext, _
strDBSiteCode, _
strSQL, _
blnReadonly, _
objADORecordset, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "GetADORecordSet Failure Abort"
GetByAny = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Exit Function
End If
Set vntADORecordset = objADORecordset
Set objADORecordset = Nothing
SetComplete mobjContext, mcstrClassName, cstrMethodName
Exit Function
ErrorHandler:
GetByAny = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
Set objADORecordset = Nothing
SetAbort mobjContext, mcstrClassName, cstrMethodName
End Function
'***********************************************************************
'* Function : CreateEmptyRS()
'* Purpose : Create an updateable recordset.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function CreateEmptyRS( _
ByVal strDBSiteCode As String, _
ByRef vntADORecordset As Variant, _
ByRef vntErrorMessage As Variant, _
Optional ByVal strColumns As String = "*") _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "CreateEmptyRS"
Dim strSQL As String
Dim objADORecordset As ADODB.Recordset
SendDebug mcstrClassName, cstrMethodName, "Start"
CreateEmptyRS = True
If Len(strColumns) = 0 Then
strColumns = "*"
End If
strSQL = "select " & _
strColumns & " " & _
"from " & _
" tag_group " & _
"where " & _
" tag_group_name = 'tag_group_name' "
If Not GetADORecordSet( _
mobjContext, _
strDBSiteCode, _
strSQL, _
False, _
objADORecordset, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "GetADORecordSet Failure Abort"
CreateEmptyRS = False
SetAbort mobjContext, mcstrClassName, cstrMethodName
Exit Function
End If
Set vntADORecordset = objADORecordset
Set objADORecordset = Nothing
SetComplete mobjContext, mcstrClassName, cstrMethodName
Exit Function
ErrorHandler:
CreateEmptyRS = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
Set objADORecordset = Nothing
SetAbort mobjContext, mcstrClassName, cstrMethodName
End Function
'***********************************************************************
'* Class : Database
'*
'* Purpose : Database related routines.
'*
'* Revision : 1.0.0 03/30/1999 James Bischoff
'* Initial release
'***********************************************************************
Option Explicit
'Every module has mcstrClassName defined for error messages
Private Const mcstrClassName As String = "Database"
'Database related global variables
Public mcstrFileDSNSuffix As String
Public Enum dbDataType
DbTypeString = 0
DbTypeNumber = 1
dbTypeDate = 2
End Enum
'***********************************************************************
'* Function : GetConnectString()
'* Purpose : Return an ADO connect string based on a site code.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetADOConnectString( _
ByVal strSiteCode As String, _
ByRef strConnectString As String, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "GetADOConnectString"
GetADOConnectString = True
SendDebug mcstrClassName, cstrMethodName, "Start"
strConnectString = "FILEDSN=" & strSiteCode & mcstrFileDSNSuffix & ".dsn"
SendDebug mcstrClassName, cstrMethodName, "Connect String [" & strConnectString & "]"
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
GetADOConnectString = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Sub : SetAbort()
'* Purpose : Call the SetAbort method on a context object
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Sub SetAbort( _
ByRef objContext As MTxAS.ObjectContext, _
ByVal strClassname As String, _
ByVal strMethodName As String)
On Error GoTo ErrorHandler
Const cstrMethodName = "SetAbort"
If Not (objContext Is Nothing) Then
If objContext.IsInTransaction Then
SendDebug strClassname, strMethodName, "Set Abort"
objContext.SetAbort
Else
SendDebug strClassname, strMethodName, "Not In Transaction"
End If
Else
SendError strClassname, strMethodName, "No Context Object to Set Abort with"
End If
Exit Sub
ErrorHandler:
SendError mcstrClassName, cstrMethodName, Err.Source & " - " & Err.Description
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'***********************************************************************
'* Sub : SetComplete()
'* Purpose : Call the SetComplete method on a context object
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Sub SetComplete( _
ByRef objContext As MTxAS.ObjectContext, _
ByVal strClassname As String, _
ByVal strMethodName As String)
On Error GoTo ErrorHandler
Const cstrMethodName = "SetComplete"
If Not (objContext Is Nothing) Then
If objContext.IsInTransaction Then
SendDebug strClassname, strMethodName, "Set Complete"
objContext.SetComplete
Else
SendDebug strClassname, strMethodName, "Not In Transaction"
End If
Else
SendError strClassname, strMethodName, "No Context Object to Set Complete with"
End If
Exit Sub
ErrorHandler:
SendError mcstrClassName, cstrMethodName, Err.Source & " - " & Err.Description
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'***********************************************************************
'* Sub : DestroyADOConnection()
'* Purpose : Close and destroy an ADO connection object.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Sub DestroyADOConnection( _
ByRef objADOConnection As ADODB.Connection, _
ByVal strClassname As String, _
ByVal strMethodName As String)
On Error GoTo ErrorHandler
Const cstrMethodName = "DestroyADOConnection"
If Not (objADOConnection Is Nothing) Then
If objADOConnection.State = adStateOpen Then
SendDebug strClassname, strMethodName, "Close ADO Connection"
objADOConnection.Close
End If
SendDebug strClassname, strMethodName, "Destroy ADO Connection Object"
Set objADOConnection = Nothing
Else
SendDebug strClassname, strMethodName, "No ADO Connection Object to Destroy"
End If
Exit Sub
ErrorHandler:
SendError mcstrClassName, cstrMethodName, Err.Source & " - " & Err.Description
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'***********************************************************************
'* Sub : CloseADOConnection()
'* Purpose : Close and destroy an ADO connection object.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Sub CloseADOConnection( _
ByRef objADOConnection As ADODB.Connection, _
ByVal strClassname As String, _
ByVal strMethodName As String)
On Error GoTo ErrorHandler
Const cstrMethodName = "CloseADOConnection"
If Not (objADOConnection Is Nothing) Then
If objADOConnection.State = adStateOpen Then
SendDebug strClassname, strMethodName, "Close ADO Connection"
objADOConnection.Close
Else
SendDebug strClassname, strMethodName, "ADO Connection Already Closed"
End If
Else
SendDebug strClassname, strMethodName, "No ADO Connection Object to Close"
End If
Exit Sub
ErrorHandler:
SendError mcstrClassName, cstrMethodName, Err.Source & " - " & Err.Description
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'***********************************************************************
'* Sub : OpenADOConnection()
'* Purpose : Close and destroy an ADO connection object.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function OpenADOConnection( _
ByVal strDBSiteCode As String, _
ByRef strLastDBSiteCode As String, _
ByRef objADOConnection As ADODB.Connection, _
ByRef vntErrorMessage As Variant, _
Optional ByVal lngCursorLocation As Long = adUseServer) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName = "OpenADOConnection"
Dim strADOConnectString As String
SendDebug mcstrClassName, cstrMethodName, "Start"
OpenADOConnection = True
If (strLastDBSiteCode <> strDBSiteCode) Or _
(objADOConnection.State = adStateClosed) Then
CloseADOConnection objADOConnection, mcstrClassName, cstrMethodName
If Not GetADOConnectString( _
strDBSiteCode, _
strADOConnectString, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "GetADOConnectString Failure Abort"
OpenADOConnection = False
Exit Function
End If
SendDebug mcstrClassName, cstrMethodName, "Open ADO Connection"
objADOConnection.CursorLocation = lngCursorLocation
objADOConnection.Open strADOConnectString
strLastDBSiteCode = strDBSiteCode
Else
SendDebug mcstrClassName, cstrMethodName, "Connection Already Open"
End If
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
OpenADOConnection = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Function : GetSQLType()
'* Purpose : See is SQL is a database write statement.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetSQLType( _
ByVal strSQL As String, _
ByRef blnIsWrite As Boolean, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "GetSQLType"
Dim lngCheckPosition As Long
SendDebug mcstrClassName, cstrMethodName, "Start"
GetSQLType = True
blnIsWrite = False
lngCheckPosition = InStr(1, UCase$(strSQL), "INSERT", vbTextCompare)
If lngCheckPosition > 0 Then
SendDebug mcstrClassName, cstrMethodName, "An Insert Query"
blnIsWrite = True
End If
lngCheckPosition = InStr(1, UCase$(strSQL), "UPDATE", vbTextCompare)
If lngCheckPosition > 0 Then
SendDebug mcstrClassName, cstrMethodName, "An Update Query"
blnIsWrite = True
End If
lngCheckPosition = InStr(1, UCase$(strSQL), "DELETE", vbTextCompare)
If lngCheckPosition > 0 Then
SendDebug mcstrClassName, cstrMethodName, "A Delete Query"
blnIsWrite = True
End If
If Not blnIsWrite Then
SendDebug mcstrClassName, cstrMethodName, "A Select Query"
End If
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
GetSQLType = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Function : GetSingleValue()
'* Purpose : Execute an SQL statement that returns one value. The target
'* column must be named Target.
'* Note : This should be used for Selects ONLY. There is no security
'* check. Is strSQL does not have the key word Select, this
'* function will return an error.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetSingleValue( _
ByVal strDBSiteCode As String, _
ByVal strSQL As String, _
ByRef vntValue As Variant, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "GetSingleValue"
Dim objADORecordset As ADODB.Recordset
Dim strADOConnectString As String
Dim blnIsWrite As Boolean
SendDebug mcstrClassName, cstrMethodName, "Start"
GetSingleValue = True
vntValue = Null
If Not GetSQLType( _
strSQL, _
blnIsWrite, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "GetSQLType Failure"
GetSingleValue = False
Exit Function
End If
If blnIsWrite Then
SendDebug mcstrClassName, cstrMethodName, "Not a Select Query"
GetSingleValue = False
Exit Function
End If
If Not GetADOConnectString( _
strDBSiteCode, _
strADOConnectString, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "GetADOConnectString Failure"
GetSingleValue = False
Exit Function
End If
SendDebug mcstrClassName, cstrMethodName, "Create ADO Recordset Object"
Set objADORecordset = New ADODB.Recordset
SendDebug mcstrClassName, cstrMethodName, "Open ADO Recordset"
objADORecordset.Open _
strSQL, _
strADOConnectString, _
adOpenForwardOnly, _
adLockReadOnly, _
adCmdText
SendDebug mcstrClassName, cstrMethodName, "Retrieve Value From ADO Recordset"
vntValue = objADORecordset!Target
SendDebug mcstrClassName, cstrMethodName, "Destroy ADO Recordset Object"
Set objADORecordset = Nothing
Exit Function
ErrorHandler:
GetSingleValue = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
SendDebug mcstrClassName, cstrMethodName, "Destroy ADO Recordset Object"
Set objADORecordset = Nothing
End Function
'***********************************************************************
'* Function : GetADORecordSet()
'* Purpose : Execute an SQL statement that returns an ADO recordset.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetADORecordSet( _
ByRef objContext As MTxAS.ObjectContext, _
ByVal strDBSiteCode As String, _
ByVal strSQL As String, _
ByVal blnReadonly As Boolean, _
ByRef objADORecordset As ADODB.Recordset, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "GetADORecordSet"
Dim objADOConnection As ADODB.Connection
Dim strADOConnectString As String
Dim blnIsWrite As Boolean
SendDebug mcstrClassName, cstrMethodName, "Start"
GetADORecordSet = True
blnIsWrite = False
If Not GetADOConnectString( _
strDBSiteCode, _
strADOConnectString, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "GetADOConnectString Failure Abort"
GetADORecordSet = False
Exit Function
End If
If Not GetSQLType( _
strSQL, _
blnIsWrite, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "GetSQLType Failure"
GetADORecordSet = False
Exit Function
End If
SendDebug mcstrClassName, cstrMethodName, "Create ADO Recordset Object"
Set objADORecordset = New ADODB.Recordset
If blnIsWrite Then
If Not ValidateWriteAccessBySite( _
mcstrClassName, _
cstrMethodName, _
strDBSiteCode, _
objContext, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "Security Failure"
GetADORecordSet = False
Exit Function
End If
SendDebug mcstrClassName, cstrMethodName, "Create ADO Connection Object"
Set objADOConnection = objContext.CreateInstance("ADODB.Connection")
SendDebug mcstrClassName, cstrMethodName, "Open ADO Connection"
objADOConnection.Open strADOConnectString
Set objADORecordset.ActiveConnection = objADOConnection
Else
objADORecordset.ActiveConnection = strADOConnectString
End If
With objADORecordset
.CursorLocation = adUseClientBatch
SendDebug mcstrClassName, cstrMethodName, strSQL
If blnReadonly Then
SendDebug mcstrClassName, cstrMethodName, "Open Read Only ADO Recordset"
.Open strSQL, , adOpenStatic, adLockReadOnly, adCmdText
Else
SendDebug mcstrClassName, cstrMethodName, "Open Updateable ADO Recordset"
.Open strSQL, , adOpenStatic, adLockBatchOptimistic, adCmdText
End If
SendDebug mcstrClassName, cstrMethodName, "Remove Connection From ADO Recordset"
Set .ActiveConnection = Nothing
End With
If blnIsWrite Then
DestroyADOConnection objADOConnection, mcstrClassName, cstrMethodName
End If
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
GetADORecordSet = False
If blnIsWrite Then
DestroyADOConnection objADOConnection, mcstrClassName, cstrMethodName
End If
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Function : AddWhereSegment()
'* Purpose : Create a where clause segment for one field.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function AddWhereSegment( _
ByVal strFieldName As String, _
ByVal strFieldMask As String, _
ByVal lngDataType As dbDataType, _
ByRef strWhere As String, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "AddWhereSegment"
Dim lngPos As Long
Dim lngOrPos As Long
Dim lngAndPos As Long
Dim lngCurrentOperatorPos As Long
Dim lngCurrentOperatorPosOffsset As Long
Dim lngLastOperatorPos As Long
Dim lngLength As Long
Dim strOperator As String
Dim strOriginalFieldMask As String
Dim strCurrentSegment As String
Dim strCurrentOperator As String
Dim blnLoop As Boolean
Dim strCurrentWhere As String
Dim strWhereSegment As String
AddWhereSegment = True
SendDebug mcstrClassName, cstrMethodName, "Start"
strOriginalFieldMask = Trim$(strFieldMask)
strFieldMask = Trim$(UCase$(strFieldMask))
lngLength = Len(strFieldMask)
If lngLength = 0 Then
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
End If
lngPos = InStr(1, strFieldMask, " IN ", vbTextCompare)
If lngPos > 1 Then
CreateErrorMessage mcstrClassName, cstrMethodName, mclngInNotSupported, vntErrorMessage, strOriginalFieldMask
AddWhereSegment = False
Exit Function
End If
lngPos = InStr(1, strFieldMask, " BETWEEN ", vbTextCompare)
If lngPos > 1 Then
CreateErrorMessage mcstrClassName, cstrMethodName, mclngBetweenNotSupported, vntErrorMessage, strOriginalFieldMask
AddWhereSegment = False
Exit Function
End If
lngPos = InStr(1, strFieldMask, "(", vbTextCompare)
If lngPos > 1 Then
CreateErrorMessage mcstrClassName, cstrMethodName, mclngParensNotSupported, vntErrorMessage, strOriginalFieldMask
AddWhereSegment = False
Exit Function
End If
lngPos = InStr(1, strFieldMask, ")", vbTextCompare)
If lngPos > 1 Then
CreateErrorMessage mcstrClassName, cstrMethodName, mclngParensNotSupported, vntErrorMessage, strOriginalFieldMask
AddWhereSegment = False
Exit Function
End If
lngLastOperatorPos = 1
blnLoop = True
While blnLoop
lngOrPos = InStr(lngLastOperatorPos, strFieldMask, " OR ", vbTextCompare)
lngAndPos = InStr(lngLastOperatorPos, strFieldMask, " AND ", vbTextCompare)
If lngOrPos <> 0 Or lngAndPos <> 0 Then
'got an and or an or
If ((lngOrPos < lngAndPos) And (lngOrPos <> 0)) Or (lngAndPos = 0) Then
lngCurrentOperatorPos = lngOrPos
lngCurrentOperatorPosOffsset = 3
strCurrentOperator = "Or"
Else
lngCurrentOperatorPos = lngAndPos
lngCurrentOperatorPosOffsset = 4
strCurrentOperator = "And"
End If
strCurrentSegment = Trim$(Mid$(strOriginalFieldMask, lngLastOperatorPos, lngCurrentOperatorPos - lngLastOperatorPos))
lngCurrentOperatorPos = lngCurrentOperatorPos + lngCurrentOperatorPosOffsset
Else
'no more and's or or's
strCurrentOperator = ""
If lngLastOperatorPos = 1 Then lngLastOperatorPos = 0
strCurrentSegment = Trim$(Right$(strOriginalFieldMask, lngLength - lngLastOperatorPos))
blnLoop = False
End If
If Not ProcessWhereSegment( _
strFieldName, _
strCurrentSegment, _
lngDataType, _
strWhereSegment, _
vntErrorMessage) Then
AddWhereSegment = False
Exit Function
End If
strCurrentWhere = Trim$(strCurrentWhere & " " & Trim$(strWhereSegment & " " & strCurrentOperator))
lngLastOperatorPos = lngCurrentOperatorPos
Wend
If Len(strWhere) > 0 Then
strWhere = strWhere & " and " & strCurrentWhere
Else
strWhere = strCurrentWhere
End If
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
AddWhereSegment = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Function : ProcessWhereSegment()
'* Purpose : Create a where segment for one clause.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function ProcessWhereSegment( _
ByVal strFieldName As String, _
ByVal strFieldMask As String, _
ByVal lngDataType As dbDataType, _
ByRef strWhereSegment As String, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "ProcessWhereSegment"
Dim blnWildCardFound As Boolean
Dim strOperator As String
Dim strLocalFieldmask As String
Dim strFormattedDate As String
ProcessWhereSegment = True
SendDebug mcstrClassName, cstrMethodName, "Start"
strFieldMask = Trim$(strFieldMask)
strLocalFieldmask = strFieldMask
If Not ConvertWildCards( _
strFieldMask, _
blnWildCardFound, _
vntErrorMessage) Then
ProcessWhereSegment = False
Exit Function
End If
' If (UCase$(Mid$(strFieldMask, 1, 6)) = "NOT IN") Or _
' (UCase$(Mid$(strFieldMask, 1, 2)) = "IN") Then
' strWhereSegment = strFieldName & " " & Trim$(strFieldMask)
' Exit Function
' End If
If Not CheckForOperators( _
strFieldMask, _
strOperator, _
vntErrorMessage) Then
ProcessWhereSegment = False
Exit Function
End If
If (Len(strOperator) > 0) And blnWildCardFound Then
CreateErrorMessage mcstrClassName, cstrMethodName, mclngInvalidWhereMask, vntErrorMessage, strLocalFieldmask
ProcessWhereSegment = False
Exit Function
End If
If blnWildCardFound Then
strWhereSegment = strFieldName & " " & strOperator & " like '" & strFieldMask & "'"
Else
If Len(strOperator) = 0 Then
strOperator = "="
End If
If lngDataType = DbTypeString Then
strWhereSegment = strFieldName & " " & strOperator & " '" & strFieldMask & "'"
Else
If lngDataType = dbTypeDate Then
If Not FormatDate( _
strFieldMask, _
strFormattedDate, _
vntErrorMessage) Then
ProcessWhereSegment = False
Exit Function
End If
strWhereSegment = strFieldName & " " & strOperator & " to_date('" & strFormattedDate & "', 'MM/DD/YYYY HH24:MI:SS')"
Else
strWhereSegment = strFieldName & " " & strOperator & " " & strFieldMask
End If
End If
End If
SendDebug mcstrClassName, cstrMethodName, "Where Segment [" & strWhereSegment & "]"
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
ProcessWhereSegment = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Function : ConvertWildCards()
'* Purpose : Convert Jet wildcards to Oracle.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function ConvertWildCards( _
ByRef strFieldMask As String, _
ByRef blnWildCardFound As Boolean, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "ConvertWildCards"
Dim lngCount As Long
Dim lngLength As Long
Dim strChar As String
Dim strLocalCopy As String
ConvertWildCards = True
blnWildCardFound = False
SendDebug mcstrClassName, cstrMethodName, "Start"
strLocalCopy = strFieldMask
strFieldMask = ""
lngLength = Len(strLocalCopy)
For lngCount = 1 To lngLength
strChar = Mid(strLocalCopy, lngCount, 1)
Select Case strChar
Case "*", "%"
strChar = "%"
blnWildCardFound = True
Case "?", "_"
strChar = "_"
blnWildCardFound = True
End Select
strFieldMask = strFieldMask & strChar
Next
SendDebug mcstrClassName, cstrMethodName, "Field Mask [" & strFieldMask & "]"
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
ConvertWildCards = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Function : CheckForOperators()
'* Purpose : See if string contains <, >, or =
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function CheckForOperators( _
ByRef strFieldMask As String, _
ByRef strOperator As String, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "CheckForOperators"
SendDebug mcstrClassName, cstrMethodName, "Start"
CheckForOperators = True
strOperator = ""
strFieldMask = Trim$(strFieldMask)
If (Mid$(strFieldMask, 1, 2) = "!=") Or (Mid$(strFieldMask, 1, 2) = "^=") Then
strOperator = "<>"
strFieldMask = Right$(strFieldMask, Len(strFieldMask) - 2)
strFieldMask = Trim$(strFieldMask)
Exit Function
End If
If Mid$(strFieldMask, 1, 1) = "<" Then
strOperator = "<"
strFieldMask = Right$(strFieldMask, Len(strFieldMask) - 1)
strFieldMask = Trim$(strFieldMask)
End If
If Mid$(strFieldMask, 1, 1) = ">" Then
strOperator = strOperator & ">"
strFieldMask = Right$(strFieldMask, Len(strFieldMask) - 1)
strFieldMask = Trim$(strFieldMask)
End If
If Mid$(strFieldMask, 1, 1) = "=" Then
strOperator = strOperator & "="
strFieldMask = Right$(strFieldMask, Len(strFieldMask) - 1)
strFieldMask = Trim$(strFieldMask)
End If
SendDebug mcstrClassName, cstrMethodName, "Operator [" & strOperator & "]"
SendDebug mcstrClassName, cstrMethodName, "FieldMask [" & strFieldMask & "]"
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
CheckForOperators = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'**************************************************************************
'* Function : FormatDate
'* Purpose : Format a date for Oracle MM/DD/YYYY HH24:MI:SS queries.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'**************************************************************************
Public Function FormatDate( _
ByVal strDate As String, _
ByRef strFormattedDate As String, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "FormatDate"
SendDebug mcstrClassName, cstrMethodName, "Start"
Dim dtmDate As Date
Dim strMonth As String
Dim strDay As String
Dim strYear As String
Dim strHour As String
Dim strMinute As String
Dim strSecond As String
FormatDate = True
On Error Resume Next
dtmDate = CDate(strDate)
If Err.Number > 0 Then
CreateErrorMessage mcstrClassName, cstrMethodName, mclngInvalidDate, vntErrorMessage, strDate
FormatDate = False
Exit Function
End If
On Error GoTo ErrorHandler
If Not ZeroFill(DatePart("m", dtmDate), 2, strMonth, vntErrorMessage) Then
FormatDate = False
Exit Function
End If
If Not ZeroFill(DatePart("d", dtmDate), 2, strDay, vntErrorMessage) Then
FormatDate = False
Exit Function
End If
If Not ZeroFill(DatePart("yyyy", dtmDate), 4, strYear, vntErrorMessage) Then
FormatDate = False
Exit Function
End If
If Not ZeroFill(DatePart("h", dtmDate), 2, strHour, vntErrorMessage) Then
FormatDate = False
Exit Function
End If
If Not ZeroFill(DatePart("n", dtmDate), 2, strMinute, vntErrorMessage) Then
FormatDate = False
Exit Function
End If
If Not ZeroFill(DatePart("s", dtmDate), 2, strSecond, vntErrorMessage) Then
FormatDate = False
Exit Function
End If
strFormattedDate = strMonth & "/" & _
strDay & "/" & _
strYear & " " & _
strHour & ":" & _
strMinute & ":" & _
strSecond
SendDebug mcstrClassName, cstrMethodName, "Formatted Date [" & strFormattedDate & "]"
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
FormatDate = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'**************************************************************************
'* Function : ZeroFill
'* Purpose : Zero fill a number.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'**************************************************************************
Public Function ZeroFill( _
ByVal lngNumber As Long, _
ByVal intMinLength As Integer, _
ByRef strZeroFilled As String, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "ZeroFill"
SendDebug mcstrClassName, cstrMethodName, "Start"
Dim intCnt As Integer
ZeroFill = True
strZeroFilled = CStr(lngNumber)
intCnt = 0
Do While intCnt < (intMinLength - Len(CStr(lngNumber)))
strZeroFilled = "0" & strZeroFilled
intCnt = intCnt + 1
Loop
SendDebug mcstrClassName, cstrMethodName, "Zero Filled Number [" & strZeroFilled & "]"
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
ZeroFill = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'**************************************************************************
'* Function : GetBatchUpdateStatus
'* Purpose : Convert ADO Status to text.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'**************************************************************************
Public Function GetBatchUpdateStatus( _
ByVal lngStatusId As Long) _
As String
On Error Resume Next
Select Case lngStatusId
Case adRecOK
GetBatchUpdateStatus = "The record was successfully updated."
Case adRecNew
GetBatchUpdateStatus = "The record is new."
Case adRecModified
GetBatchUpdateStatus = "The record was modified."
Case adRecDeleted
GetBatchUpdateStatus = "The record was deleted."
Case adRecUnmodified
GetBatchUpdateStatus = "The record was not modified."
Case adRecInvalid
GetBatchUpdateStatus = "The record was not saved because its AbsolutePosition is invalid."
Case adRecMultipleChanges
GetBatchUpdateStatus = "The record was not saved because it would have affected multiple records."
Case adRecPendingChanges
GetBatchUpdateStatus = "The record was not saved because it refers to a pending insert."
Case adRecCanceled
GetBatchUpdateStatus = "The record was not saved because the operation was canceled."
Case adRecCantRelease
GetBatchUpdateStatus = "The new record was not saved because of existing record locks."
Case adRecConcurrencyViolation
GetBatchUpdateStatus = "The record was not saved because optimistic concurrency was in use."
Case adRecIntegrityViolation
GetBatchUpdateStatus = "The record was not saved because the user violated integrity constraints."
Case adRecMaxChangesExceeded
GetBatchUpdateStatus = "The record was not saved because there were too many pending changes."
Case adRecObjectOpen
GetBatchUpdateStatus = "The record was not saved because of a conflict with an open storage object."
Case adRecOutOfMemory
GetBatchUpdateStatus = "The record was not saved because the computer has run out of memory."
Case adRecPermissionDenied
GetBatchUpdateStatus = "The record was not saved because the user has insufficient permissions."
Case adRecSchemaViolation
GetBatchUpdateStatus = "The record was not saved because it violates the structure of the underlying database."
Case adRecDBDeleted
GetBatchUpdateStatus = "The record has already been deleted from the data source."
Case Else
GetBatchUpdateStatus = "Undefined record status."
End Select
End Function
'***********************************************************************
'* Function : SubmitRSBatch()
'* Purpose : Submit an updateable recordset for batch update.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function SubmitRSBatch( _
ByRef objContext As MTxAS.ObjectContext, _
ByVal strDBSiteCode As String, _
ByRef vntADORecordset As Variant, _
ByRef vntStatus() As Variant, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "SubmitRSBatch"
Dim objADOConnection As ADODB.Connection
Dim objADORecordset As ADODB.Recordset
Dim strADOConnectString As String
Dim strErrorMessage As String
SendDebug mcstrClassName, cstrMethodName, "Start"
SubmitRSBatch = True
SendDebug mcstrClassName, cstrMethodName, "Check For Work"
Set objADORecordset = vntADORecordset
Set vntADORecordset = Nothing
objADORecordset.Filter = adFilterPendingRecords
If objADORecordset.RecordCount = 0 Then
SendDebug mcstrClassName, cstrMethodName, "No Record Changes Present"
SubmitRSBatch = True
Set vntADORecordset = objADORecordset
Exit Function
End If
If Not ValidateWriteAccessBySite( _
mcstrClassName, _
cstrMethodName, _
strDBSiteCode, _
objContext, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "Security Failure Abort"
SubmitRSBatch = False
Exit Function
End If
If Not GetADOConnectString( _
strDBSiteCode, _
strADOConnectString, _
vntErrorMessage) Then
SendDebug mcstrClassName, cstrMethodName, "GetADOConnectString Failure Abort"
SubmitRSBatch = False
Exit Function
End If
SendDebug mcstrClassName, cstrMethodName, "Create ADO Connection Object"
Set objADOConnection = objContext.CreateInstance("ADODB.Connection")
objADOConnection.CursorLocation = adUseClient
SendDebug mcstrClassName, cstrMethodName, "Open ADO Connection"
objADOConnection.Open strADOConnectString
With objADORecordset
SendDebug mcstrClassName, cstrMethodName, "Assign ADO Connection To Recordset"
Set .ActiveConnection = objADOConnection
.Filter = adFilterPendingRecords
If .RecordCount > 0 Then
SendDebug mcstrClassName, cstrMethodName, "Dimension Status Array For Deletes"
ReDim vntStatus(1, 1 To .RecordCount)
End If
SendDebug mcstrClassName, cstrMethodName, "Process Batch Deletes"
While Not .EOF
If .EditMode = adEditDelete Then
SendDebug mcstrClassName, cstrMethodName, "Execute Delete"
On Error Resume Next
.UpdateBatch adAffectCurrent
If .Status = (adRecConcurrencyViolation Or adRecDeleted) Then
SendDebug mcstrClassName, cstrMethodName, "Record Already Deleted"
ElseIf .ActiveConnection.Errors.Count > 0 Then
SendDebug mcstrClassName, cstrMethodName, "Delete Failed Status = " & CStr(.Status)
strErrorMessage = .ActiveConnection.Errors(0)
.CancelBatch adAffectCurrent
SendDebug mcstrClassName, cstrMethodName, "Execute Rollback on " & CStr(objADORecordset.AbsolutePosition)
If (.Status <> adRecOK) And _
(.Status <> adRecUnmodified) Then
SendDebug mcstrClassName, cstrMethodName, "Delete Rollback Failed"
Else
SendDebug mcstrClassName, cstrMethodName, "Delete Rollback Succeeded"
End If
vntStatus(0, .AbsolutePosition) = False
If Len(strErrorMessage) = 0 Then
vntStatus(1, .AbsolutePosition) = "ERROR [Unspecified Error]"
Else
vntStatus(1, .AbsolutePosition) = "ERROR [" & strErrorMessage & "]"
End If
Else
SendDebug mcstrClassName, cstrMethodName, "Delete Succeeded"
End If
On Error GoTo ErrorHandler
End If
objADORecordset.MoveNext
Wend
.Filter = adFilterNone
If .RecordCount > 0 Then
SendDebug mcstrClassName, cstrMethodName, "Dimension Status Array For All Changes"
ReDim Preserve vntStatus(1, 1 To .RecordCount)
Else
ReDim vntStatus(1, 1)
End If
'Process all non delete changes
SendDebug mcstrClassName, cstrMethodName, "Process Batch Inserts and Updates"
While Not .EOF
Select Case .EditMode
Case adEditAdd
SendDebug mcstrClassName, cstrMethodName, "Execute Add"
On Error Resume Next
.UpdateBatch adAffectCurrent
If (.Status <> adRecOK) And _
(.Status <> adRecUnmodified) Then
SendDebug mcstrClassName, cstrMethodName, "Add Failed"
vntStatus(0, .AbsolutePosition) = False
strErrorMessage = .ActiveConnection.Errors(0)
If Len(strErrorMessage) = 0 Then
vntStatus(1, .AbsolutePosition) = "ERROR [Unspecified Error]"
Else
vntStatus(1, .AbsolutePosition) = "ERROR [" & strErrorMessage & "]"
End If
Else
SendDebug mcstrClassName, cstrMethodName, "Add Succeeded"
vntStatus(0, .AbsolutePosition) = True
vntStatus(1, .AbsolutePosition) = "OK [Record Added]"
End If
On Error GoTo ErrorHandler
Case adEditInProgress
SendDebug mcstrClassName, cstrMethodName, "Execute Update"
On Error Resume Next
.UpdateBatch adAffectCurrent
If .Status And adRecConcurrencyViolation Then
SendDebug mcstrClassName, cstrMethodName, "Concurrency Violation"
vntStatus(0, .AbsolutePosition) = False
vntStatus(1, .AbsolutePosition) = "ERROR [Record Refreshed From Database]"
.Resync adAffectCurrent, adResyncAllValues
ElseIf (.Status <> adRecOK) And _
(.Status <> adRecUnmodified) Then
SendDebug mcstrClassName, cstrMethodName, "Update Failed"
vntStatus(0, .AbsolutePosition) = False
strErrorMessage = .ActiveConnection.Errors(0)
If Len(strErrorMessage) = 0 Then
vntStatus(1, .AbsolutePosition) = "ERROR [Unspecified Error]"
Else
vntStatus(1, .AbsolutePosition) = "ERROR [" & strErrorMessage & "]"
End If
Else
SendDebug mcstrClassName, cstrMethodName, "Update Succeeded"
vntStatus(0, .AbsolutePosition) = True
vntStatus(1, .AbsolutePosition) = "OK [Record Updated]"
End If
On Error GoTo ErrorHandler
Case Else
SendDebug mcstrClassName, cstrMethodName, "Record Unchanged"
End Select
.MoveNext
Wend
SendDebug mcstrClassName, cstrMethodName, "Remove Connection From ADO Recordset"
Set .ActiveConnection = Nothing
Set vntADORecordset = objADORecordset
End With
DestroyADOConnection objADOConnection, mcstrClassName, cstrMethodName
SendDebug mcstrClassName, cstrMethodName, "Start"
Exit Function
ErrorHandler:
SubmitRSBatch = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
Set objADORecordset.ActiveConnection = Nothing
DestroyADOConnection objADOConnection, mcstrClassName, cstrMethodName
End Function
'***********************************************************************
'* Class : Constants
'*
'* Purpose : Read registry entries into global values.
'*
'* Revision : 1.0.0 03/30/1999 James Bischoff
'* Initial release
'***********************************************************************
Option Explicit
'Every module has mcstrClassName defined for error messages
Private Const mcstrClassName As String = "Constants"
'These are all of the non-error related global constants
Public Const mclngDebugToFile As Long = 10
'These are defaults in case registry values are missing
Public Const mcstrDefaultErrDir As String = "C:\"
Public Const mcstrDefaultMsgDir As String = "C:\"
Public Const mclngDefaultTraceLevel As Long = 1
Public Const mclngDefaultSecurityGateTraceLevel As Long = 10
Public Const mcstrDefaultWriteGroupDomain As String = "PROCESS"
Public Const mcstrDefaultWriteGroupRoleSuffix As String = " Eclipse Change"
Public Const mcblnDefaultUseProgrammaticSecurity As Boolean = True
Public Const mcblnDefaultUseMTSRoles As Boolean = False
Public Const mcblnDefaultUseMTSUserCall As Boolean = False
Public Const mcstrDefaultFileDSNSuffix As String = "Eclipse"
'***********************************************************************
'* Sub : SetupGlobalValues()
'* Purpose : Called by ObjectControl_Activate in all data objects.
'* This sub reads all configuration variables out of the
'* registry and loads the values into global variables.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Sub SetupGlobalValues(strBaseRegistryKey, strAppName)
On Error GoTo ErrorHandler
Const cstrMethodName As String = "SetupGlobalValues"
Dim objRegistryEclipse As Registry.Eclipse
Dim objStringsStandard As Strings.Standard
Dim vntValue As Variant
Dim strMsgDir As String
Dim strErrDir As String
Dim strTmpDir As String
Dim strFileName As String
Dim objFileSystem As Scripting.FileSystemObject
Set objRegistryEclipse = New Registry.Eclipse
Set objStringsStandard = New Strings.Standard
Set objFileSystem = New Scripting.FileSystemObject
'*****************************************************************
'* Establish Defaults
'*****************************************************************
strErrDir = mcstrDefaultErrDir
strMsgDir = mcstrDefaultMsgDir
strFileName = strErrDir & "\" & strAppName & "Err.txt"
mobjLocalMessenger.SetErrorFile strFileName
strFileName = strMsgDir & "\" & strAppName & "Msg.txt"
mobjLocalMessenger.SetMessageFile strFileName
mlngTraceLevel = mclngDefaultTraceLevel
mlngSecurityGateTraceLevel = mclngDefaultSecurityGateTraceLevel
mstrWriteGroupDomain = mcstrDefaultWriteGroupDomain
mstrWriteGroupRoleSuffix = mcstrDefaultWriteGroupRoleSuffix
mblnUseProgrammaticSecurity = mcblnDefaultUseProgrammaticSecurity
mblnUseMTSRoles = mcblnDefaultUseMTSRoles
mblnUseMTSUserCall = mcblnDefaultUseMTSUserCall
mcstrFileDSNSuffix = mcstrDefaultFileDSNSuffix
objRegistryEclipse.SetMessageParameters _
mobjLocalMessenger, _
mcstrClassName, _
mlngTraceLevel
objStringsStandard.SetMessageParameters _
mobjLocalMessenger, _
mcstrClassName, _
mlngTraceLevel
'*****************************************************************
'* Read Registry
'*****************************************************************
vntValue = Null
objRegistryEclipse.GetEclipseVariable _
"TRACE_ERR_DIR", _
strBaseRegistryKey, _
vntValue
If IsNull(vntValue) Then
SendError mcstrClassName, cstrMethodName, "Value Not Found In [" & strBaseRegistryKey & "\TRACE_ERR_DIR]"
Else
strTmpDir = CStr(objStringsStandard.RemoveNullFromString(vntValue))
If objFileSystem.FolderExists(strTmpDir) Then
strErrDir = strTmpDir
Else
On Error Resume Next
objFileSystem.CreateFolder strTmpDir
If Err.Number > 0 Then
SendError mcstrClassName, cstrMethodName, "Could Not Create TRACE_ERR_DIR [" & strTmpDir & "] Error [" & Err.Description & "]"
Else
strErrDir = strTmpDir
End If
On Error GoTo ErrorHandler
End If
End If
strFileName = strErrDir & "\" & strAppName & "Err.txt"
mobjLocalMessenger.SetErrorFile strFileName
vntValue = Null
objRegistryEclipse.GetEclipseVariable _
"TRACE_MSG_DIR", _
strBaseRegistryKey, _
vntValue
If IsNull(vntValue) Then
SendError mcstrClassName, cstrMethodName, "Value Not Found In [" & strBaseRegistryKey & "\TRACE_MSG_DIR]"
Else
strTmpDir = CStr(objStringsStandard.RemoveNullFromString(vntValue))
If objFileSystem.FolderExists(strTmpDir) Then
strMsgDir = strTmpDir
Else
On Error Resume Next
objFileSystem.CreateFolder strTmpDir
If Err.Number > 0 Then
SendError mcstrClassName, cstrMethodName, "Could Not Create TRACE_MSG_DIR [" & strTmpDir & "] Error [" & Err.Description & "]"
Else
strMsgDir = strTmpDir
End If
On Error GoTo ErrorHandler
End If
End If
strFileName = strMsgDir & "\" & strAppName & "Msg.txt"
mobjLocalMessenger.SetMessageFile strFileName
vntValue = Null
objRegistryEclipse.GetEclipseVariable _
"TRACE_LEVEL", _
strBaseRegistryKey, _
vntValue
If IsNull(vntValue) Then
SendError mcstrClassName, cstrMethodName, "Value Not Found In [" & strBaseRegistryKey & "\TRACE_LEVEL]"
Else
If IsNumeric(vntValue) Then
mlngTraceLevel = CLng(objStringsStandard.RemoveNullFromString(vntValue))
Else
SendError mcstrClassName, cstrMethodName, "Value Not Numeric In [" & strBaseRegistryKey & "\TRACE_LEVEL]"
End If
End If
objRegistryEclipse.SetMessageParameters _
mobjLocalMessenger, _
mcstrClassName, _
mlngTraceLevel
objStringsStandard.SetMessageParameters _
mobjLocalMessenger, _
mcstrClassName, _
mlngTraceLevel
vntValue = Null
objRegistryEclipse.GetEclipseVariable _
"SECURITYGATE_TRACE_LEVEL", _
strBaseRegistryKey, _
vntValue
If IsNull(vntValue) Then
SendError mcstrClassName, cstrMethodName, "Value Not Found In [" & strBaseRegistryKey & "\SECURITYGATE_TRACE_LEVEL]"
Else
If IsNumeric(vntValue) Then
mlngSecurityGateTraceLevel = CLng(objStringsStandard.RemoveNullFromString(vntValue))
Else
SendError mcstrClassName, cstrMethodName, "Value Not Numeric In [" & strBaseRegistryKey & "\SECURITYGATE_TRACE_LEVEL]"
End If
End If
vntValue = Null
objRegistryEclipse.GetEclipseVariable _
"WRITE_GROUP_DOMAIN", _
strBaseRegistryKey, _
vntValue
If IsNull(vntValue) Then
SendError mcstrClassName, cstrMethodName, "Value Not Found In [" & strBaseRegistryKey & "\WRITE_GROUP_DOMAIN]"
Else
mstrWriteGroupDomain = CStr(objStringsStandard.RemoveNullFromString(vntValue))
End If
vntValue = Null
objRegistryEclipse.GetEclipseVariable _
"WRITE_GROUP_ROLE_SUFFIX", _
strBaseRegistryKey, _
vntValue
If IsNull(vntValue) Then
SendError mcstrClassName, cstrMethodName, "Value Not Found In [" & strBaseRegistryKey & "\WRITE_GROUP_ROLE_SUFFIX]"
Else
mstrWriteGroupRoleSuffix = CStr(objStringsStandard.RemoveNullFromString(vntValue))
End If
vntValue = Null
objRegistryEclipse.GetEclipseVariable _
"USE_PROGRAMMATIC_SECURITY", _
strBaseRegistryKey, _
vntValue
If IsNull(vntValue) Then
SendError mcstrClassName, cstrMethodName, "Value Not Found In [" & strBaseRegistryKey & "\USE_PROGRAMMATIC_SECURITY]"
Else
Select Case UCase(CStr(objStringsStandard.RemoveNullFromString(vntValue)))
Case "TRUE"
mblnUseProgrammaticSecurity = True
Case "FALSE"
mblnUseProgrammaticSecurity = False
Case Else
SendError mcstrClassName, cstrMethodName, "Value Not TRUE or FALSE In [" & strBaseRegistryKey & "\USE_PROGRAMMATIC_SECURITY]"
End Select
End If
vntValue = Null
objRegistryEclipse.GetEclipseVariable _
"USE_MTS_ROLES", _
strBaseRegistryKey, _
vntValue
If IsNull(vntValue) Then
SendError mcstrClassName, cstrMethodName, "Value Not Found In [" & strBaseRegistryKey & "\USE_MTS_ROLES]"
Else
Select Case UCase(CStr(objStringsStandard.RemoveNullFromString(vntValue)))
Case "TRUE"
mblnUseMTSRoles = True
Case "FALSE"
mblnUseMTSRoles = False
Case Else
SendError mcstrClassName, cstrMethodName, "Value Not TRUE or FALSE In [" & strBaseRegistryKey & "\USE_MTS_ROLES]"
End Select
End If
vntValue = Null
objRegistryEclipse.GetEclipseVariable _
"USE_MTS_USERCALL", _
strBaseRegistryKey, _
vntValue
If IsNull(vntValue) Then
SendError mcstrClassName, cstrMethodName, "Value Not Found In [" & strBaseRegistryKey & "\USE_MTS_USERCALL]"
Else
Select Case UCase(CStr(objStringsStandard.RemoveNullFromString(vntValue)))
Case "TRUE"
mblnUseMTSUserCall = True
Case "FALSE"
mblnUseMTSUserCall = False
Case Else
SendError mcstrClassName, cstrMethodName, "Value Not TRUE or FALSE In [" & strBaseRegistryKey & "\USE_MTS_USERCALL]"
End Select
End If
vntValue = Null
objRegistryEclipse.GetEclipseVariable _
"FILE_DSN_SUFFIX", _
strBaseRegistryKey, _
vntValue
If IsNull(vntValue) Then
SendError mcstrClassName, cstrMethodName, "Value Not Found In [" & strBaseRegistryKey & "\FILE_DSN_SUFFIX]"
Else
mcstrFileDSNSuffix = CStr(objStringsStandard.RemoveNullFromString(vntValue))
End If
SendDebug mcstrClassName, cstrMethodName, "Start"
SendDebug mcstrClassName, cstrMethodName, "TRACE_LEVEL = [" & CStr(mlngTraceLevel) & "]"
SendDebug mcstrClassName, cstrMethodName, "SECURITYGATE_TRACE_LEVEL = [" & CStr(mlngSecurityGateTraceLevel) & "]"
SendDebug mcstrClassName, cstrMethodName, "TRACE_ERR_DIR = [" & strErrDir & "]"
SendDebug mcstrClassName, cstrMethodName, "TRACE_MSG_DIR = [" & strMsgDir & "]"
SendDebug mcstrClassName, cstrMethodName, "WRITE_GROUP_DOMAIN = [" & mstrWriteGroupDomain & "]"
SendDebug mcstrClassName, cstrMethodName, "WRITE_GROUP_ROLE_SUFFIX = [" & mstrWriteGroupRoleSuffix & "]"
SendDebug mcstrClassName, cstrMethodName, "USE_PROGRAMMATIC_SECURITY = [" & CStr(mblnUseProgrammaticSecurity) & "]"
SendDebug mcstrClassName, cstrMethodName, "USE_MTS_ROLES = [" & CStr(mblnUseMTSRoles) & "]"
SendDebug mcstrClassName, cstrMethodName, "USE_MTS_USERCALL = [" & CStr(mblnUseMTSUserCall) & "]"
SendDebug mcstrClassName, cstrMethodName, "Destroy Utility Objects"
Set objRegistryEclipse = Nothing
Set objStringsStandard = Nothing
Set objFileSystem = Nothing
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Sub
ErrorHandler:
SendError mcstrClassName, cstrMethodName, Err.Source & " - " & Err.Description
SendDebug mcstrClassName, cstrMethodName, "Destroy Utility Objects"
Set objRegistryEclipse = Nothing
Set objStringsStandard = Nothing
Set objFileSystem = Nothing
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'***********************************************************************
'* Class : Errors
'*
'* Purpose : Define all application errors and associated messages.
'*
'* Revision : 1.0.0 03/30/1999 James Bischoff
'* Initial release
'***********************************************************************
Option Explicit
'Every module has mcstrClassName defined for error messages
Private Const mcstrClassName As String = "Errors"
'All application error constants are defined below
Public Const mclngUndefined As Long = 0
Public Const mclngMTSAccessDenied As Long = 1
Public Const mclngGroupAccessDenied As Long = 2
Public Const mclngSecurityNotEnabled As Long = 3
Public Const mclngRoleUndefined As Long = 4
Public Const mclngInvalidWhereMask As Long = 5
Public Const mclngBetweenNotSupported = 6
Public Const mclngInvalidDate = 7
Public Const mclngMultipleRecordUpdate = 8
Public Const mclngInNotSupported = 9
Public Const mclngParensNotSupported = 10
'***********************************************************************
'* Function : CreateErrorMessage()
'* Purpose : Create and output an error message.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function CreateErrorMessage( _
ByVal strClassname As String, _
ByVal strMethodName As String, _
ByVal lngErrorNumber As Long, _
ByRef vntMessage As Variant, _
Optional ByVal strMessageParam As String = "") _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "CreateErrorMessage"
Dim strErrorMessage As String
Dim strComputerName As String
CreateErrorMessage = True
Select Case lngErrorNumber
Case mclngMTSAccessDenied
strErrorMessage = "ERROR: You do not have write permission." & vbCrLf & _
"User Not in MTS Role [" & strMessageParam & "]."
Case mclngGroupAccessDenied
strErrorMessage = "EROR: You do not have write permission." & vbCrLf & _
"User Not in Group [" & strMessageParam & "]."
Case mclngSecurityNotEnabled
strErrorMessage = "ERROR: MTS Security must be enabled"
Case mclngRoleUndefined
strErrorMessage = "ERROR: MTS Role [" & strMessageParam & "] Not defined."
Case mclngInvalidWhereMask
strErrorMessage = "ERROR: Field Mask [" & strMessageParam & "] cannot contain " & _
"wildcards (*,?,%,_) and operators (<,>,=) at the same time."
Case mclngBetweenNotSupported
strErrorMessage = "ERROR: Field Mask [" & strMessageParam & "] cannot contain " & _
"the BETWEEN operator. Try using >= AND <=."
Case mclngInNotSupported
strErrorMessage = "ERROR: Field Mask [" & strMessageParam & "] cannot contain " & _
"the IN operator. Try using OR."
Case mclngParensNotSupported
strErrorMessage = "ERROR: Field Mask [" & strMessageParam & "] cannot contain " & _
"( or ) characters. If you need this feature, contact the Galaxy development Team."
Case mclngInvalidDate
strErrorMessage = "ERROR: Invalid Date [" & strMessageParam & "]."
Case mclngMultipleRecordUpdate
strErrorMessage = "ERROR: Attempted to update multiple records simultaneously " & _
"in table [" & strMessageParam & "]."
Case Else
If Len(strMessageParam) > 0 Then
strErrorMessage = "ERROR: " & strMessageParam
Else
strErrorMessage = "ERROR: Undefined Error"
End If
End Select
vntMessage = strErrorMessage
SendError strClassname, strMethodName, CStr(vntMessage)
Exit Function
ErrorHandler:
CreateErrorMessage = False
vntMessage = strErrorMessage & " - " & _
Err.Source & " - " & Err.Description
SendError mcstrClassName, cstrMethodName, CStr(vntMessage)
End Function
'***********************************************************************
'* Class : Message
'*
'* Purpose : All application debug messages are routed through this
'* module.
'*
'* Revision : 1.0.0 03/30/1999 James Bischoff
'* Initial release
'***********************************************************************
Option Explicit
'Every module has mcstrClassName defined for error messages
Private Const mcstrClassName As String = "Message"
'Message related global variables
Public mobjLocalMessenger As BayCore.Debug
Public mlngTraceLevel As Long
'***********************************************************************
'* Sub : SetupLocalMessenger()
'* Purpose : Create an instance of the LocalMessenger. Only one is
'* needed per process. This object is never explicitly
'* destroyed.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Sub SetupLocalMessenger()
On Error GoTo ErrorHandler
If mobjLocalMessenger Is Nothing Then
'Set mobjLocalMessenger = New LocalMessenger
Set mobjLocalMessenger = New BayCore.Debug
End If
Exit Sub
ErrorHandler:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'***********************************************************************
'* Function : RemoveCrLf()
'* Purpose : Replace vbCrLf with a space for Debug output.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Private Function RemoveCrLf( _
ByVal strString As String) _
As String
On Error GoTo ErrorHandler
Const cstrMethodName = "RemoveCrLf"
Dim objStringsStandard As Strings.Standard
Set objStringsStandard = New Strings.Standard
RemoveCrLf = objStringsStandard.RemoveCrLf(strString)
Set objStringsStandard = Nothing
Exit Function
ErrorHandler:
Set objStringsStandard = Nothing
Err.Raise Err.Number, Err.Source, Err.Description
End Function
'**************************************************************************
'* Sub : SendDebug, SendError, SendDebug
'* Purpose : Output messages using the LocalMessenger object.
'*
'* SendLocalMessage takes the following string parameters:
'*
'* Type = Error, Warning, Message, Debug
'* Channel = File, Debug, Event, All
'* AppName = Application Name
'* Message = The Message
'*
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'**************************************************************************
'**************************************************************************
'* Debug Only
'**************************************************************************
Public Sub SendDebug( _
ByVal strClassname As String, _
ByVal strMethodName As String, _
ByVal strMessage As String, _
Optional ByVal lngMinDebug As Long = 1)
On Error Resume Next
If mlngTraceLevel >= mclngDebugToFile Then
strMessage = RemoveCrLf(strMethodName & " {" & strMessage & "}")
mobjLocalMessenger.SendLocalMessage _
"Debug", _
"File", _
strClassname, _
strMessage
Else
If mlngTraceLevel >= lngMinDebug Then
strMessage = RemoveCrLf(strMethodName & " {" & strMessage & "}")
mobjLocalMessenger.SendLocalMessage _
"Debug", _
"Debug", _
strClassname, _
strMessage
End If
End If
End Sub
'**************************************************************************
'* Debug and File
'**************************************************************************
Public Sub SendMessage( _
ByVal strClassname As String, _
ByVal strMethodName As String, _
ByVal strMessage As String)
On Error Resume Next
strMessage = RemoveCrLf(strMethodName & " {" & strMessage & "}")
mobjLocalMessenger.SendLocalMessage _
"Message", _
"File", _
strClassname, _
strMessage
' SendDebug strClassname, strMethodName, strMessage
End Sub
'**************************************************************************
'* Debug, File, and Event Log
'**************************************************************************
Public Sub SendError( _
ByVal strClassname As String, _
ByVal strMethodName As String, _
ByVal strMessage As String)
On Error Resume Next
strMessage = RemoveCrLf(strMethodName & " {" & strMessage & "}")
mobjLocalMessenger.SendLocalMessage _
"Error", _
"All", _
strClassname, _
strMessage
End Sub
'***********************************************************************
'* Class : Security
'*
'* Purpose : Determine if users have write access to the database.
'*
'* Revision : 1.0.0 03/30/1999 James Bischoff
'* Initial release
'***********************************************************************
Option Explicit
'Every module has mcstrClassName defined for error messages
Private Const mcstrClassName As String = "Security"
'Security related global variables
Public mstrWriteGroupRoleSuffix As String
Public mlngSecurityGateTraceLevel As Long
Public mstrWriteGroupDomain As String
Public mblnUseProgrammaticSecurity As Boolean
Public mblnUseMTSRoles As Boolean
Public mblnUseMTSUserCall As Boolean
'***********************************************************************
'* Function : ValidateWriteAccessBySite()
'* Purpose : Get the correct role and see if current user is in it.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function ValidateWriteAccessBySite( _
ByVal strClassname As String, _
ByVal strMethodName As String, _
ByVal strSiteCode As String, _
ByRef objContext As MTxAS.ObjectContext, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName = "ValidateWriteAccessBySite"
Dim strRoleName As String
SendDebug mcstrClassName, cstrMethodName, "Start"
ValidateWriteAccessBySite = False
vntErrorMessage = ""
If mblnUseProgrammaticSecurity Then
SendDebug mcstrClassName, cstrMethodName, "Use Programmatic Security"
If objContext Is Nothing Then
CreateErrorMessage strClassname, strMethodName, mclngSecurityNotEnabled, vntErrorMessage
Else
If GetGroupRoleName( _
strSiteCode, _
strRoleName, _
vntErrorMessage) Then
If ValidateWriteAccess( _
strClassname, _
strMethodName, _
strRoleName, _
objContext, _
mstrWriteGroupDomain, _
mblnUseMTSRoles, _
vntErrorMessage) Then
ValidateWriteAccessBySite = True
SendDebug mcstrClassName, cstrMethodName, "User Validated"
Else
SendDebug mcstrClassName, cstrMethodName, "User NOT Validated"
End If
End If
End If
Else
SendDebug mcstrClassName, cstrMethodName, "Use Declarative Security"
ValidateWriteAccessBySite = True
End If
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Function : GetGroupRoleName()
'* Purpose : Return a group (or role) name based on a site code.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetGroupRoleName( _
ByVal strSiteCode As String, _
ByRef srtRoleName As String, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName As String = "GetGroupRoleName"
GetGroupRoleName = True
SendDebug mcstrClassName, cstrMethodName, "Start"
srtRoleName = strSiteCode & mstrWriteGroupRoleSuffix
SendDebug mcstrClassName, cstrMethodName, "Role [" & srtRoleName & "]"
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
GetGroupRoleName = False
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Function : ValidateWriteAccess()
'* Purpose : Use either MTS Roles or NT Groups to validate the user.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function ValidateWriteAccess( _
ByVal strClassname As String, _
ByVal strMethodName As String, _
ByVal strRoleName As String, _
ByRef objContext As MTxAS.ObjectContext, _
ByVal strGroupDomain As String, _
ByVal blnUseMTSRoles As Boolean, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName = "ValidateWriteAccess"
SendDebug mcstrClassName, cstrMethodName, "Start"
ValidateWriteAccess = False
vntErrorMessage = ""
If blnUseMTSRoles Then
SendDebug mcstrClassName, cstrMethodName, "Using MTS Roles"
ValidateWriteAccess = ValidateRoleBasedAccess( _
strClassname, _
strMethodName, _
strRoleName, _
objContext, _
vntErrorMessage)
Else
SendDebug mcstrClassName, cstrMethodName, "Using NT Groups"
ValidateWriteAccess = ValidateGroupBasedAccess( _
strClassname, _
strMethodName, _
strRoleName, _
objContext, _
strGroupDomain, _
vntErrorMessage)
End If
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Function : ValidateRoleBasedAccess()
'* Purpose : See if direct caller is in the specified role.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function ValidateRoleBasedAccess( _
ByVal strClassname As String, _
ByVal strMethodName As String, _
ByVal strRoleName As String, _
ByVal objContext As MTxAS.ObjectContext, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName = "ValidateRoleBasedAccess"
SendDebug mcstrClassName, cstrMethodName, "Start"
ValidateRoleBasedAccess = False
vntErrorMessage = ""
If objContext.IsSecurityEnabled() Then
SendDebug mcstrClassName, cstrMethodName, "MTS Security Enabled"
On Error Resume Next
If Not objContext.IsCallerInRole(strRoleName) Then
If Err.Number Then
CreateErrorMessage strClassname, strMethodName, mclngRoleUndefined, vntErrorMessage, strRoleName
Else
CreateErrorMessage strClassname, strMethodName, mclngMTSAccessDenied, vntErrorMessage, strRoleName
End If
Else
ValidateRoleBasedAccess = True
End If
On Error GoTo ErrorHandler
Else
CreateErrorMessage strClassname, strMethodName, mclngSecurityNotEnabled, vntErrorMessage
End If
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
End Function
'***********************************************************************
'* Function : ValidateGroupBasedAccess()
'* Purpose : See if Original caller caller is in the specified group.
'* Revision : 1.0.0 04/08/1999 James Bischoff
'* Initial release
'***********************************************************************
Public Function ValidateGroupBasedAccess( _
ByVal strClassname As String, _
ByVal strMethodName As String, _
ByVal strGroupName As String, _
ByVal objContext As MTxAS.ObjectContext, _
ByVal strGroupDomain As String, _
ByRef vntErrorMessage As Variant) _
As Boolean
On Error GoTo ErrorHandler
Const cstrMethodName = "ValidateGroupBasedAccess"
Dim objSecurityGate As SecurityGate
Dim vntSecurityMessage As Variant
Dim vntDomain As Variant
Dim vntUser As Variant
Dim vntValidated As Variant
Dim strDomainUser As String
SendDebug mcstrClassName, cstrMethodName, "Start"
ValidateGroupBasedAccess = False
vntErrorMessage = ""
SendDebug mcstrClassName, cstrMethodName, "Create SecurityGate Object"
Set objSecurityGate = objContext.CreateInstance("SecurityGate")
If mlngTraceLevel >= mlngSecurityGateTraceLevel Then
SendDebug mcstrClassName, cstrMethodName, "Turn SecurityGate Trace On"
objSecurityGate.SetTraceLevel CLng(1)
End If
If mblnUseMTSUserCall Then
SendDebug mcstrClassName, cstrMethodName, "Use MTS User Call"
strDomainUser = UCase(objContext.Security.GetOriginalCallerName())
vntDomain = CVar(Left(strDomainUser, InStr(1, strDomainUser, "\", vbTextCompare) - 1))
vntUser = CVar(Right(strDomainUser, Len(strDomainUser) - InStr(1, strDomainUser, "\", vbTextCompare)))
Else
SendDebug mcstrClassName, cstrMethodName, "Use SecurityGate User Call"
If objSecurityGate.GetDomainUser( _
vntDomain, _
vntUser, _
vntSecurityMessage) Then
Else
CreateErrorMessage strClassname, strMethodName, mclngUndefined, vntErrorMessage, CStr(vntSecurityMessage)
Exit Function
End If
End If
SendDebug mcstrClassName, cstrMethodName, "User [" & CStr(vntDomain) & "\" & CStr(vntUser) & "]"
If objSecurityGate.ValidateDomainUser( _
vntDomain, _
vntUser, _
CVar(strGroupDomain), _
CVar(strGroupName), _
vntValidated, _
vntSecurityMessage) Then
If CBool(vntValidated) Then
ValidateGroupBasedAccess = True
Else
CreateErrorMessage strClassname, strMethodName, mclngGroupAccessDenied, vntErrorMessage, strGroupDomain & "\" & strGroupName
End If
Else
CreateErrorMessage strClassname, strMethodName, mclngUndefined, vntErrorMessage, CStr(vntSecurityMessage)
End If
If mlngTraceLevel >= mlngSecurityGateTraceLevel Then
SendDebug mcstrClassName, cstrMethodName, "Turn SecurityGate Trace Off"
objSecurityGate.SetTraceLevel CLng(0)
End If
SendDebug mcstrClassName, cstrMethodName, "Destroy SecurityGate Object"
Set objSecurityGate = Nothing
SendDebug mcstrClassName, cstrMethodName, "End"
Exit Function
ErrorHandler:
CreateErrorMessage mcstrClassName, cstrMethodName, mclngUndefined, vntErrorMessage, Err.Source & " - " & Err.Description
If Not (objSecurityGate Is Nothing) Then
If mlngTraceLevel >= mlngSecurityGateTraceLevel Then
objSecurityGate.SetTraceLevel CLng(0)
End If
SendDebug mcstrClassName, cstrMethodName, "Destroy SecurityGate Object"
Set objSecurityGate = Nothing
End If
End Function
|
