www.pudn.com > sqlserverdbfz.rar > CNorthwindDB.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "CNorthwindDB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'This database class was generated by CLASSter(tm)
'from Urfin Jus (www.urfinjus.net). Copyright 2000, All rights reserved.
' CLASSter Version: Build 1.2.88 Demo
' Date: 04 Jun 2001, 03:17
' Connection string used: "Driver=SQL Server;UID=sa;PWD=;Server=; Database=Northwind"
' Dependencies: MS ADO Library; MS ADO Recordset Library
' HuntERR25.Bas
'
'
'Public Class Members:
'===============================================================================
' Methods for calling individual stored procedures.
'Public Function ExecCustOrderHist(ByVal CustomerID As String) As Long
'Public Function ExecCustOrdersDetail(ByRef OrderID As Long) As Long
'Public Function ExecCustOrdersOrders(ByVal CustomerID As String) As Long
'Public Function ExecEmployeeSalesByCountry(ByVal Beginning_Date As Date, _
' ByVal Ending_Date As Date) As Long
'Public Function ExecSalesByYear(ByVal Beginning_Date As Date, _
' ByVal Ending_Date As Date) As Long
'Public Function ExecSalesByCategory(ByVal CategoryName As String, _
' ByVal OrdYear As String) As Long
'Public Function ExecTenMostExpensiveProducts As Long
'
' Executes SP by name
'Public Function ExecSPbyName(ByVal SPName As String, ByVal ParamDefs As String, _
' ByVal arrValues, Optional ByRef RS) As Boolean
'
' Executes SQL statement
'Public Function ExecSQL(ByVal SQL As String, Optional ByRef RS) As Boolean
'
' Recordset
'Public Property Get Recordset() As ADODB.Recordset
'Public Property Get RecordCount() As Long
'Public Function MoveFirst() As Boolean
'Public Function MoveLast() As Boolean
'Public Function MoveNext() As Boolean
'Public Function MovePrevious() As Boolean
'Public Property Get EOF() As Boolean
'Public Property Get BOF() As Boolean
'
' Safely retrieves field value, returns empty value if field value is Null
'Public Property Get Value(ByVal FieldName As String) As Variant
'
' Multiple Recordsets
'Public Function SelectNextRecordset() As Boolean
'
' ADO
'Public Property Get ConnectionString() As String
'Public Property Let ConnectionString(ByVal AValue As String)
'Public Property Get Connection() As ADODB.Connection
'Public Property Get Command() As ADODB.Command
'Public Sub ReleaseConnection()
'Public Sub SetADOSettings( _
' Optional ByVal ACursorLocation As Long = adUseClient, _
' Optional ByVal ACursorType As Long = adOpenForwardOnly, _
' Optional ByVal ALockType As Long = adLockReadOnly, _
' Optional ByVal AConnectionTimeout As Long = 5, _
' Optional ByVal ACommandTimeout As Long = 60)
'Public Sub ReleaseADO()
'
' Parameters
'Public Function ParamIsNull(ByVal ParamName As String) As Boolean
'Public Property Get ParamValue(ByVal ParamName As String) As Variant
'Public Property Get ReturnValue() As Long
'Public Function GetParameter(ByVal ParamName As String) As ADODB.Parameter
'
' Transactions
'Public Function BeginTransaction() As Boolean
'Public Function SetComplete() As Boolean
'Public Function SetAbort() As Boolean
'
'Batch mode
'Public Property Get BatchActive() As Boolean
'Public Function BatchBegin() As Boolean
'Public Function BatchDeclareVar(ByVal VarName As String, _
' ByVal VarType As String, _
' Optional ByVal UseForParams As String, _
' Optional ByVal Value As String) As Boolean
'Public Function BatchExec() As Boolean
'Public Function BatchCancel() As Boolean
'Public Property Get BatchText() As String
'
' XML
'Public Function xmlGetRecordset() As String
'Public Function xmlGetRecordsetExt(ByVal RsDataElem As String, _
' ByVal ZRowElem As String) As String
'
' Returns all recordsets in one XML message
'Public Function xmlGetAllRecordsets(ByVal RootElem As String, _
' ByVal RsDataElems As String, _
' ByVal ZRowElems As String) As String
'
'
Option Explicit
Option Base 0
'
'Return value parameter name
Const RETURN_VALUE = "RETURN_VALUE"
'
'Error map enum. Defines error ranges for UJ reserved errors, exceptions, and
'custom application errors. Must be included into exactly one public class.
' Notes:
' 1. Define your custom errors starting with ERRDB_LAST + 1.
' 2. EXC_GENERAL and ERR_GENERAL may be used by your application if specific error number
' is not needed.
' 3. Error numbers (vbObjectError + [1..4096]) are used by OLE DB;
' See support.microsoft.com/support/kb/articles/Q168/3/54.ASP
'
Public Enum ENUM_ERRMAP
ERRMAP_FIRST = vbObjectError + 4096 'vbObjectError = $H80040000 = -2147221504
ERRMAP_RESERVED_FIRST = ERRMAP_FIRST 'Errors reserved for HuntERR and UJ apps.
ERRMAP_STACK_TRACE = ERRMAP_RESERVED_FIRST ' Stack tracing: used by HuntERR
ERRMAP_RESERVED_LAST = ERRMAP_RESERVED_FIRST + 100
ERRMAP_EXC_FIRST = ERRMAP_RESERVED_LAST + 1 'Exceptions - reraised by ErrorIn
EXC_GENERAL = ERRMAP_EXC_FIRST
ERRMAP_EXC_LAST = ERRMAP_EXC_FIRST + 1000
ERRMAP_APP_FIRST = ERRMAP_EXC_LAST + 1
ERR_GENERAL = ERRMAP_APP_FIRST
'Application errors
End Enum
'
'Errors raised by database class code
Public Enum ENUM_ERRDB
ERRDB_BATCH_NOT_ACTIVE = ERRMAP_APP_FIRST + 1
ERRDB_NO_CONNECTION_STRING
ERRDB_REGISTRY_FAILED
ERRDB_INVALID_PARAM_COUNT
ERRDB_TYPE_NOT_SUPPORTED
ERRDB_SP_RETURNED_NON_ZERO
ERRDB_STRING_TOO_LONG
ERRDB_LAST = ERRDB_STRING_TOO_LONG 'Use this constant as a basis for your app errors
End Enum
'
'ADO objects
Private mConnection As ADODB.Connection
Private mCommand As ADODB.Command
Private mRecordset As ADODB.Recordset
Private mConnectionString As String
Private mConnectionAssigned As Boolean
'
'ADO Settings
Private mADOSettingsInitialized As Boolean
Private mCursorType As Long, mLockType As Long, mCursorLocation As Long
Private mConnectionTimeout As Long, mCommandTimeout As Long
'
' Set to True when Connection.BeginTrans is called,
' set to false on Commit and Rollback
Private mInADOTransaction As Boolean
'
'Batch mode member variables
Private mBatchActive As Boolean, mBatchText As String, mBatchVars As Collection
'
'The following flags control actions performed by ErrorIn function.
'These actions may be different depending on type of method
'(public or private) that ErrorIn is called from.
'Private methods ALWAYS reraise errors. Public methods reraise
'errors only if user selected Reraise option in CLASSter
'Error Handling page. Only public methods do actions regarding
'current transaction, private methods never do this.
Const EA_PRIVATE = EA_ADVANCED + EA_RERAISE 'Actions for private methods
Const EA_PUBLIC = EA_ADVANCED + EA_RERAISE 'Actions for public methods
'
Const STR_DEFAULT_CONNECTION = "Driver=SQL Server;UID=sa;PWD=;Server=; Database=Northwind"
'
' Methods for calling individual stored procedures.
'
Public Function ExecCustOrderHist(ByVal CustomerID As String) As Long
On Error GoTo errHandler
InitCommand
AddParam RETURN_VALUE, ADODB.adInteger, ADODB.adParamReturnValue, 4, 0
AddParam "@CustomerID", adVarWChar, adParamInput, 5, IIf(CustomerID = "", Null, CustomerID)
ExecSP "[CustOrderHist]"
ExecCustOrderHist = PrmValue(RETURN_VALUE)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.ExecCustOrderHist(CustomerID)", Array(CustomerID), _
EA_PUBLIC, mConnection
End Function
Public Function ExecCustOrdersDetail(ByRef OrderID As Long) As Long
On Error GoTo errHandler
InitCommand
AddParam RETURN_VALUE, ADODB.adInteger, ADODB.adParamReturnValue, 4, 0
AddParam "@OrderID", adInteger, adParamInputOutput, 0, IIf(OrderID = 0, Null, OrderID)
ExecSP "[CustOrdersDetail]"
OrderID = PrmValue("@OrderID")
ExecCustOrdersDetail = PrmValue(RETURN_VALUE)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.ExecCustOrdersDetail(OrderID)", Array(OrderID), _
EA_PUBLIC, mConnection
End Function
Public Function ExecCustOrdersOrders(ByVal CustomerID As String) As Long
On Error GoTo errHandler
InitCommand
AddParam RETURN_VALUE, ADODB.adInteger, ADODB.adParamReturnValue, 4, 0
AddParam "@CustomerID", adVarWChar, adParamInput, 5, IIf(CustomerID = "", Null, CustomerID)
ExecSP "[CustOrdersOrders]"
ExecCustOrdersOrders = PrmValue(RETURN_VALUE)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.ExecCustOrdersOrders(CustomerID)", Array(CustomerID), _
EA_PUBLIC, mConnection
End Function
Public Function ExecEmployeeSalesByCountry(ByVal Beginning_Date As Date, _
ByVal Ending_Date As Date) As Long
On Error GoTo errHandler
InitCommand
AddParam RETURN_VALUE, ADODB.adInteger, ADODB.adParamReturnValue, 4, 0
AddParam "@Beginning_Date", adDBTimeStamp, adParamInput, 0, IIf(Beginning_Date = 0, Null, Beginning_Date)
AddParam "@Ending_Date", adDBTimeStamp, adParamInput, 0, IIf(Ending_Date = 0, Null, Ending_Date)
ExecSP "[Employee Sales by Country]"
ExecEmployeeSalesByCountry = PrmValue(RETURN_VALUE)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.ExecEmployeeSalesByCountry(Beginning_Date," & _
"Ending_Date)", Array(Beginning_Date, Ending_Date), EA_PUBLIC, mConnection
End Function
Public Function ExecSalesByYear(ByVal Beginning_Date As Date, _
ByVal Ending_Date As Date) As Long
On Error GoTo errHandler
InitCommand
AddParam RETURN_VALUE, ADODB.adInteger, ADODB.adParamReturnValue, 4, 0
AddParam "@Beginning_Date", adDBTimeStamp, adParamInput, 0, IIf(Beginning_Date = 0, Null, Beginning_Date)
AddParam "@Ending_Date", adDBTimeStamp, adParamInput, 0, IIf(Ending_Date = 0, Null, Ending_Date)
ExecSP "[Sales by Year]"
ExecSalesByYear = PrmValue(RETURN_VALUE)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.ExecSalesByYear(Beginning_Date,Ending_Date)", _
Array(Beginning_Date, Ending_Date), EA_PUBLIC, mConnection
End Function
Public Function ExecSalesByCategory(ByVal CategoryName As String, _
ByVal OrdYear As String) As Long
On Error GoTo errHandler
InitCommand
AddParam RETURN_VALUE, ADODB.adInteger, ADODB.adParamReturnValue, 4, 0
AddParam "@CategoryName", adVarWChar, adParamInput, 15, IIf(CategoryName = "", Null, CategoryName)
AddParam "@OrdYear", adVarWChar, adParamInput, 4, IIf(OrdYear = "", Null, OrdYear)
ExecSP "[SalesByCategory]"
ExecSalesByCategory = PrmValue(RETURN_VALUE)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.ExecSalesByCategory(CategoryName,OrdYear)", _
Array(CategoryName, OrdYear), EA_PUBLIC, mConnection
End Function
Public Function ExecTenMostExpensiveProducts() As Long
On Error GoTo errHandler
InitCommand
AddParam RETURN_VALUE, ADODB.adInteger, ADODB.adParamReturnValue, 4, 0
ExecSP "[Ten Most Expensive Products]"
ExecTenMostExpensiveProducts = PrmValue(RETURN_VALUE)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.ExecTenMostExpensiveProducts", , EA_PUBLIC, _
mConnection
End Function
'
' Executes SP by name
' ParamDefs string constants may be generated by CLASSter
' in a separate *.Bas module.
' Example:
' DBClass.ExecSP "CustOrdersDetail", PRM_CUSTORDERSDETAIL, Array(OrderID)
Public Function ExecSPbyName(ByVal SPName As String, ByVal ParamDefs As String, _
ByVal arrValues, Optional ByRef RS) As Boolean
On Error GoTo errHandler
InitCommand
RebuildParams ParamDefs, arrValues
ExecSP SPName
If Not IsMissing(RS) Then Set RS = mRecordset
ExecSPbyName = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.ExecSPByName(SPName,ParamDefs,ArrValues)", _
Array(SPName, ParamDefs, arrValues), EA_PUBLIC, mConnection
End Function
Private Sub RebuildParams(ByVal ParamDefs As String, ByVal arrValues)
Dim arrParamDefs() As String, arrParamDef() As String, i As Long
Dim V, NumDefs As Long, NumVals As Long
On Error GoTo errHandler
arrParamDefs = Split(ParamDefs, ";")
NumDefs = UBound(arrParamDefs) + 1
NumVals = UBound(arrValues) + 1
Check NumDefs = NumVals, ERRDB_INVALID_PARAM_COUNT, _
"Invalid number of parameters. Expected: " & NumDefs & _
" Provided: " & NumVals
AddParam RETURN_VALUE, ADODB.adInteger, ADODB.adParamReturnValue, 4, 0
For i = 0 To NumDefs - 1
arrParamDef = Split(arrParamDefs(i), ",")
V = arrValues(i)
If Not IsNull(V) Then SubstParamValue arrParamDef(0), arrParamDef(4), V
AddParam arrParamDef(0), arrParamDef(1), arrParamDef(2), arrParamDef(3), V
Next i
Exit Sub
errHandler:
ErrorIn "CNorthwindDB.RebuildParams", arrValues, EA_PRIVATE
End Sub
'ParamName is provided only for error handling
Private Sub SubstParamValue(ByVal ParamName As String, ByVal SubstCode As Long, _
ByRef V As Variant)
On Error GoTo errHandler
Select Case SubstCode
Case 0: 'no substitute
Case 1: If CLng(V) = 0 Then V = Null 'Int 0 as Null
Case 2: If CDate(V) = 0 Then V = Null '0 date as Null
Case 3: If CStr(V) = "" Then V = Null 'empty string as Null
End Select
Exit Sub
errHandler:
ErrorIn "CNorthwindDB.SubstParamValue(ParamName,SubstCode,V)", _
Array(ParamName, SubstCode, V), EA_PRIVATE
End Sub
'
' Executes SQL statement
Public Function ExecSQL(ByVal SQL As String, Optional ByRef RS) As Boolean
On Error GoTo errHandler
If mBatchActive Then
mBatchText = mBatchText & SQL & ";" & vbNewLine
Exit Function
End If
InitCommand
With mCommand
.CommandType = adCmdText
.CommandText = SQL
End With
OpenConnection
Set mCommand.ActiveConnection = mConnection
OpenRecordset
If Not IsMissing(RS) Then Set RS = mRecordset
ExecSQL = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.ExecSQL(SQL)", SQL, EA_PUBLIC, mConnection
End Function
'
' Recordset
Public Property Get Recordset() As ADODB.Recordset
Set Recordset = mRecordset
End Property
Public Property Get RecordCount() As Long
On Error GoTo errHandler
RecordCount = Recordset.RecordCount
Exit Property
errHandler:
ErrorIn "CNorthwindDB.RecordCount", , EA_PUBLIC
End Property
Public Function MoveFirst() As Boolean
On Error GoTo errHandler
Recordset.MoveFirst
MoveFirst = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.MoveFirst", , EA_PUBLIC
End Function
Public Function MoveLast() As Boolean
On Error GoTo errHandler
Recordset.MoveLast
MoveLast = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.MoveLast", , EA_PUBLIC
End Function
Public Function MoveNext() As Boolean
On Error GoTo errHandler
Recordset.MoveNext
MoveNext = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.MoveNext", , EA_PUBLIC
End Function
Public Function MovePrevious() As Boolean
On Error GoTo errHandler
Recordset.MovePrevious
MovePrevious = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.MovePrevious", , EA_PUBLIC
End Function
Public Property Get EOF() As Boolean
On Error GoTo errHandler
EOF = Recordset.EOF
Exit Property
errHandler:
ErrorIn "CNorthwindDB.EOF", , EA_PUBLIC
End Property
Public Property Get BOF() As Boolean
On Error GoTo errHandler
BOF = Recordset.BOF
Exit Property
errHandler:
ErrorIn "CNorthwindDB.BOF", , EA_PUBLIC
End Property
'
' Safely retrieves field value, returns empty value if field value is Null
Public Property Get Value(ByVal FieldName As String) As Variant
Dim F As ADODB.Field
On Error GoTo errHandler
Set F = Recordset.Fields(FieldName)
If Not IsNull(F.Value) Then Value = F.Value 'If field value is Null Value returns Empty
Exit Property
errHandler:
ErrorIn "CNorthwindDB.Value(AFieldName)", FieldName, EA_PUBLIC
End Property
'
' Multiple Recordsets
' Returns true if next recordset was selected.
Public Function SelectNextRecordset() As Boolean
On Error GoTo errHandler
If mRecordset Is Nothing Then Exit Function ' returning false
'operation is not possible for unconnected recordsets
If mRecordset.ActiveConnection Is Nothing Then Exit Function
Set mRecordset = Recordset.NextRecordset
CheckRecordsetIsOpen
CheckADOErrors
SelectNextRecordset = Not (mRecordset Is Nothing)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.SelectNextRecordset", , EA_PUBLIC
End Function
'
' ADO
Public Property Get ConnectionString() As String
If mConnectionAssigned Then
ConnectionString = mConnectionString
Else
ConnectionString = STR_DEFAULT_CONNECTION
End If
End Property
Public Property Let ConnectionString(ByVal AValue As String)
ReleaseConnection
mConnectionString = AValue
mConnectionAssigned = True
End Property
Public Property Get Connection() As ADODB.Connection
Set Connection = mConnection
End Property
Public Property Get Command() As ADODB.Command
Set Command = mCommand
End Property
Public Sub ReleaseConnection()
Set mConnection = Nothing
If Not mRecordset Is Nothing Then Set mRecordset.ActiveConnection = Nothing
End Sub
Private Sub OpenConnection()
On Error GoTo errHandler
'We reuse Connection object, so create it and open
'only if wasn't created yet.
If mConnection Is Nothing Then
Check ConnectionString <> "", ERRDB_NO_CONNECTION_STRING, _
"Connection string is empty."
If Not mADOSettingsInitialized Then SetADOSettings 'Set defaults
Set mConnection = New ADODB.Connection
With mConnection
.ConnectionString = ConnectionString
.CursorLocation = mCursorLocation
.ConnectionTimeout = mConnectionTimeout
.CommandTimeout = mCommandTimeout
.Open
End With
End If
Exit Sub
errHandler:
ErrorIn "CNorthwindDB.OpenConnection", , EA_PRIVATE, mConnection, "ConnectionString", _
ConnectionString
End Sub
Public Sub SetADOSettings( _
Optional ByVal ACursorLocation As Long = adUseClient, _
Optional ByVal ACursorType As Long = adOpenForwardOnly, _
Optional ByVal ALockType As Long = adLockReadOnly, _
Optional ByVal AConnectionTimeout As Long = 5, _
Optional ByVal ACommandTimeout As Long = 60)
ReleaseADO
mCursorLocation = ACursorLocation
mCursorType = ACursorType
mLockType = ALockType
mConnectionTimeout = AConnectionTimeout
mCommandTimeout = ACommandTimeout
mADOSettingsInitialized = True
End Sub
Public Sub ReleaseADO()
Set mConnection = Nothing
Set mCommand = Nothing
Set mRecordset = Nothing
End Sub
'
' Parameters
Public Function ParamIsNull(ByVal ParamName As String) As Boolean
On Error GoTo errHandler
ParamIsNull = IsNull(mCommand.Parameters(ParamName).Value)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.ParamIsNull(ParamName)", ParamName, EA_PUBLIC, mConnection
End Function
Public Property Get ParamValue(ByVal ParamName As String) As Variant
Dim P As ADODB.Parameter
On Error GoTo errHandler
Set P = mCommand.Parameters(ParamName)
If Not IsNull(P.Value) Then ParamValue = P.Value
Exit Property
errHandler:
ErrorIn "CNorthwindDB.ParamValue(ParamName)", ParamName, EA_PUBLIC
End Property
Private Property Get PrmValue(ByVal ParamName As String) As Variant
Dim P As ADODB.Parameter
On Error GoTo errHandler
Set P = mCommand.Parameters(ParamName)
If Not IsNull(P.Value) Then PrmValue = P.Value
Exit Property
errHandler:
ErrorIn "CNorthwindDB.PrmValue(ParamName)", ParamName, EA_PRIVATE
End Property
Public Property Get ReturnValue() As Long
ReturnValue = ParamValue(RETURN_VALUE)
End Property
Public Function GetParameter(ByVal ParamName As String) As ADODB.Parameter
On Error GoTo errHandler
Set GetParameter = mCommand.Parameters(ParamName)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.GetParameter(ParamName)", ParamName, EA_PUBLIC, mConnection
End Function
Private Sub AddParam(ByVal ParamName As String, _
ByVal ParamType As ADODB.DataTypeEnum, _
ByVal ParamDir As ADODB.ParameterDirectionEnum, _
ByVal ParamSize As Long, _
ByVal ParamValue As Variant)
On Error GoTo errHandler
ParamValue = IIf(IsEmpty(ParamValue), Null, ParamValue)
With mCommand
.Parameters.Append .CreateParameter(ParamName, ParamType, _
ParamDir, ParamSize, ParamValue)
End With
Exit Sub
errHandler:
ErrorIn "CNorthwindDB.AddParam(ParamName,ParamType,ParamDir," & _
"ParamSize,ParamValue)", Array(ParamName, ParamType, ParamDir, _
ParamSize, ParamValue), EA_PRIVATE
End Sub
Private Function IsCharParam(ByVal ParamADOType As Long) As Boolean
Select Case ParamADOType
Case adBSTR, adChar, adLongVarChar, adLongVarWChar, adVarChar, adVarWChar, adWChar
IsCharParam = True
End Select
End Function
'
' Transactions
Public Function BeginTransaction() As Boolean
On Error GoTo errHandler
OpenConnection
mConnection.BeginTrans
mInADOTransaction = True
BeginTransaction = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.BeginTransaction", , EA_PUBLIC, mConnection
End Function
Public Function SetComplete() As Boolean
On Error GoTo errHandler
If mInADOTransaction Then
mConnection.CommitTrans
mInADOTransaction = False
End If
SetComplete = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.SetComplete", , EA_PUBLIC, mConnection
End Function
Public Function SetAbort() As Boolean
On Error GoTo errHandler
If mInADOTransaction Then
mConnection.RollbackTrans
mInADOTransaction = False
End If
SetAbort = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.SetAbort", , EA_PUBLIC, mConnection
End Function
'
'Batch mode
Public Property Get BatchActive() As Boolean
BatchActive = mBatchActive
End Property
Public Function BatchBegin() As Boolean
On Error GoTo errHandler
mBatchActive = True
mBatchText = ""
Set mBatchVars = New Collection
BatchBegin = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.BatchBegin", , EA_PUBLIC
End Function
'Adds declaration of a variable to the output batch. If Value is specified, adds
' SET VarName = VarValue;
' operator as well to assign initial value to a batch variable.
' If UseForParams is not specified or empty, then uses variable's name for
' matching to parameters' names.
Public Function BatchDeclareVar(ByVal VarName As String, _
ByVal VarType As String, _
Optional ByVal UseForParams As String, _
Optional ByVal Value As String) As Boolean
Dim arrParams() As String, i As Long
On Error GoTo errHandler
Check mBatchActive, ERRDB_BATCH_NOT_ACTIVE, "Batch mode is not ON"
mBatchText = mBatchText & "DECLARE " & VarName & " " & _
VarType & ";" & vbNewLine
If Value <> "" Then 'assign initial value
mBatchText = mBatchText & "SET " & VarName & " = " & Value & ";" & vbNewLine
End If
If UseForParams = "" Then
mBatchVars.Add VarName, LCase$(VarName)
Else
arrParams = Split(UseForParams, ",")
For i = LBound(arrParams) To UBound(arrParams)
mBatchVars.Add VarName, Trim$(LCase$(arrParams(i)))
Next i
End If 'UseForParams
BatchDeclareVar = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.BatchDeclareVar(VarName,VarType,UseForParams)", _
Array(VarName, VarType, UseForParams), EA_PUBLIC
End Function
'Execs batch
Public Function BatchExec() As Boolean
On Error GoTo errHandler
Check mBatchActive, ERRDB_BATCH_NOT_ACTIVE, "Batch mode is not ON"
If Not mADOSettingsInitialized Then SetADOSettings 'Set defaults
OpenConnection
Set mCommand = New ADODB.Command
With mCommand
.CommandType = adCmdText
.CommandText = mBatchText
Set .ActiveConnection = mConnection
End With
OpenRecordset
mBatchActive = False
Set mBatchVars = Nothing
BatchExec = True
Exit Function
errHandler:
ErrorIn "CNorthwindDB.BatchExec", , EA_PUBLIC, mConnection, _
"BatchText", Replace(mBatchText, vbNewLine, " ")
End Function
Public Function BatchCancel() As Boolean
mBatchActive = False
Set mBatchVars = Nothing
BatchCancel = True
End Function
Public Property Get BatchText() As String
BatchText = mBatchText
End Property
'Called in Batch mode to add "EXEC ..." string to batch for currently
' called "SP-executing" method. See comments for BatchDeclareVar method
Private Sub BatchTranslateCommand(ByVal SPName As String)
Dim strExec As String, P As ADODB.Parameter, Delim As String, VarName As String
On Error GoTo errHandler
strExec = "EXEC " & SPName
Delim = " " 'Delimiter for the list is comma, except there is no comma before first param
For Each P In mCommand.Parameters
If P.Direction <> ADODB.adParamReturnValue Then
VarName = BatchVarNameForParamName(LCase$(P.Name))
If VarName = "" Then
'don't use declared variable; use parameter's value
strExec = strExec & Delim & BatchParamValueAsString(P.Name, P.Type, P.Value)
Else
'use declared variable; also check if it has OUTPUT attribute
strExec = strExec & Delim & VarName
If P.Direction = adParamInputOutput Or P.Direction = adParamOutput Then
strExec = strExec & " OUTPUT"
End If 'P.Direction.....
End If 'KeyExists....
Delim = ", " 'after first cycle separate params with comma
End If 'P.Type ...
Next P
mBatchText = mBatchText & strExec & ";" & vbNewLine
Exit Sub
errHandler:
ErrorIn "CNorthwindDB.BatchTranslateCommand(SPName)", SPName, EA_PRIVATE
End Sub
Private Function BatchVarNameForParamName(ByVal ParamName As String) As String
On Error Resume Next
BatchVarNameForParamName = mBatchVars(ParamName)
End Function
Private Function BatchParamValueAsString(ByVal ParamName As String, _
ByVal ParamADOType As Long, _
ByVal ParamValue) As String
'ParamName is only for error reporting
'We expect error may happen when converting to string, and it's OK:
'for example, parameter is of type Date and is OUTPUT so value was not assigned
If IsNull(ParamValue) Then
BatchParamValueAsString = "Null"
Else
Select Case ParamADOType
Case adBigInt, adUnsignedBigInt, adUnsignedInt, adUnsignedSmallInt, _
adInteger, adSmallInt, adTinyInt, adUnsignedTinyInt, _
adDouble, adSingle, adDecimal, adNumeric, adCurrency
BatchParamValueAsString = "0"
On Error Resume Next
BatchParamValueAsString = ParamValue
Case adBSTR, adChar, adLongVarChar, adLongVarWChar, adVarChar, adVarWChar, adWChar
BatchParamValueAsString = "'" & Replace(ParamValue, "'", "''") & "'"
Case adBoolean 'adBoolean corresponds to Bit SQL type, so it should be 0 or 1
BatchParamValueAsString = IIf(ParamValue, "1", "0")
Case adDBTimeStamp, adDate, adDBDate, adDBTime
BatchParamValueAsString = "'01/01/1900'" 'Default values
On Error Resume Next
BatchParamValueAsString = "'" & CDate(ParamValue) & "'"
Case adGUID
BatchParamValueAsString = "''"
On Error Resume Next
BatchParamValueAsString = "'" & ParamValue & "'"
Case Else
On Error GoTo errHandler
Err.Raise ERRDB_TYPE_NOT_SUPPORTED, "BatchParamValueAsString", "Parameter " & ParamName & _
": parameters of this type(P.Type=" & ParamADOType & ") " & _
" are not supported in batch mode. "
End Select
End If 'IsNull(....
Exit Function
errHandler:
ErrorIn "CNorthwindDB.BatchParamAsString(ParamName,ParamType,ParamValue)", _
Array(ParamName, ParamADOType, ParamValue), EA_PRIVATE
End Function
'
' XML
Public Function xmlGetRecordset() As String
On Error GoTo errHandler
xmlGetRecordset = xmlGetRecordsetPriv
Exit Function
errHandler:
ErrorIn "CNorthwindDB.xmlGetRecordset", , EA_PUBLIC
End Function
Public Function xmlGetRecordsetExt(ByVal RsDataElem As String, _
ByVal ZRowElem As String) As String
On Error GoTo errHandler
xmlGetRecordsetExt = xmlGetRecordsetExtPriv(RsDataElem, ZRowElem)
Exit Function
errHandler:
ErrorIn "CNorthwindDB.xmlGetRecordsetExt(RsDataElem, ZRowElem)", _
Array(RsDataElem, ZRowElem), EA_PUBLIC
End Function
Private Function xmlGetRecordsetPriv() As String
Dim S As ADODB.Stream
On Error GoTo errHandler
Set S = New ADODB.Stream
S.Open
Recordset.Save S, adPersistXML
S.Position = 0
xmlGetRecordsetPriv = S.ReadText
Exit Function
errHandler:
ErrorIn "CNorthwindDB.xmlGetRecordsetPriv", , EA_PRIVATE
End Function
Private Function xmlGetRecordsetExtPriv(ByVal RsDataElem As String, _
ByVal ZRowElem As String) As String
Dim P1 As Long, P2 As Long, xml As String
On Error GoTo errHandler
xml = xmlGetRecordsetPriv
'Extract data rows only, apart from schema
P1 = InStr(1, xml, "") + Len("")
P2 = InStr(1, xml, " ")
If P2 > P1 And P1 > 0 Then xml = Mid$(xml, P1, P2 - P1) Else xml = ""
'Change z:row element names
xml = xmlChangeElemName(xml, "z:row", ZRowElem)
'Embrace in root element
If RsDataElem <> "" Then xml = "<" & RsDataElem & ">" & xml & ""
xmlGetRecordsetExtPriv = xml
Exit Function
errHandler:
ErrorIn "CNorthwindDB.xmlGetRecordsetExtPriv(RsDataElem,ZRowElem)", _
Array(RsDataElem, ZRowElem), EA_PRIVATE
End Function
'We can use string matching, because patterns include special symbols that
'are always escaped in XML attribute values
Private Function xmlChangeElemName(ByVal xml As String, _
ByVal OldName As String, _
ByVal NewName As String) As String
xml = Replace(xml, "<" & OldName & " ", "<" & NewName & " ")
xml = Replace(xml, "<" & OldName & ">", "<" & NewName & ">")
xml = Replace(xml, "<" & OldName & "/>", "<" & NewName & "/>")
xml = Replace(xml, "", "")
xmlChangeElemName = xml
End Function
'
' Returns all recordsets in one XML message
'Examples:
'xml = xmlGetAllRecordsets("CustomersAndOrders", "Customers,Orders", "Customer,Order") --
'xml = xmlGetAllRecordsets("CustOrders", ",Orders", "Customer,Order") '-- Customer object is directly under root
Public Function xmlGetAllRecordsets(ByVal RootElem As String, _
ByVal RsDataElems As String, _
ByVal ZRowElems As String) As String
Dim arrRsDataElems() As String, arrZRowElems() As String, Cnt As Long, xml As String
On Error GoTo errHandler
arrRsDataElems = Split(RsDataElems, ",")
arrZRowElems = Split(ZRowElems, ",")
Cnt = 0
Do
xml = xml & xmlGetRecordsetExtPriv(arrRsDataElems(Cnt), arrZRowElems(Cnt))
Cnt = Cnt + 1
Loop While SelectNextRecordset
xmlGetAllRecordsets = "<" & RootElem & ">" & xml & ""
Exit Function
errHandler:
ErrorIn "CNorthwindDB.xmlGetAllRecordsetsExt(RootElem,RsDataElems,ZRowElems)", _
Array(RootElem, RsDataElems, ZRowElems), EA_PUBLIC
End Function
Private Sub InitCommand()
On Error GoTo errHandler
If Not mADOSettingsInitialized Then SetADOSettings 'Set defaults
Set mCommand = New ADODB.Command
mCommand.CommandTimeout = mCommandTimeout
Exit Sub
errHandler:
ErrorIn "CNorthwindDB.InitCommand", , EA_PRIVATE
End Sub
Private Sub ExecSP(ByVal SPName As String)
On Error GoTo errHandler
With mCommand
.CommandType = adCmdStoredProc
.CommandText = SPName
End With
If mBatchActive Then
BatchTranslateCommand SPName
Exit Sub
End If
OpenConnection
Set mCommand.ActiveConnection = mConnection
OpenRecordset
Check PrmValue(RETURN_VALUE) = 0, ERRDB_SP_RETURNED_NON_ZERO, _
"Stored procedure returned non-zero value."
Exit Sub
errHandler:
ErrorIn "CNorthwindDB.ExecSP(SPName)", SPName, EA_PRIVATE
End Sub
Private Sub OpenRecordset()
On Error GoTo errHandler
Set mRecordset = New ADODB.Recordset
mRecordset.CursorLocation = mCursorLocation
mRecordset.Open mCommand, , mCursorType, mLockType
CheckRecordsetIsOpen
CheckADOErrors
Exit Sub
errHandler:
'mConnection provides ability for ErrorIn to grab
'ADO errors if there were any
ErrorIn "CNorthwindDB.OpenRecordset", , EA_PRIVATE, mConnection
End Sub
' Note: Most of the time, if there was an error in SQL Server ADO raises error (in Recordset.Open method).
' However, sometimes for some providers error is not raised, but put to "sleep" in recordset.
' This method checks for such errors. To wake up the error, you need to "touch" recordset.
' If there are errors, Connection.Errors collection will be filled up, and error will be raised.
' We don't know for sure the right way to wake up ADO errors in Recordset object but RecordCount property
' seems to be working.
Private Sub CheckADOErrors()
Dim Cnt As Long
On Error GoTo errHandler
If mRecordset Is Nothing Then Exit Sub
If mRecordset.State <> ADODB.adStateOpen Then Exit Sub
Cnt = mRecordset.RecordCount
Exit Sub
errHandler:
ErrorIn "CNorthwindDB.CheckADOErrors", , EA_PRIVATE, mRecordset
End Sub
'
Private Sub CheckRecordsetIsOpen()
On Error GoTo errHandler
If mRecordset Is Nothing Then Exit Sub
While (mRecordset.State = adStateClosed)
Set mRecordset = mRecordset.NextRecordset
If mRecordset Is Nothing Then Exit Sub
Wend
Exit Sub
errHandler:
ErrorIn "CNorthwindDB.CheckRecordsetIsOpen", , EA_PRIVATE
End Sub