Option Explicit
Private Const CLASS_NAME As String = "ITDATA.ADO."
Private mstrCS As String 'Default connect string which read from Registry
Private mlngRA As Long 'Record Affected by INSERT, UPDATE, DELETE
Private Const CLASS_NAME As String = "ITDATA.ADO."
Private mstrCS As String 'Default connect string which read from Registry
Private mlngRA As Long 'Record Affected by INSERT, UPDATE, DELETE
'* strSQL - SQL statement{INSERT|UPDATE|DELETE|SELECT} *
'* lngRecordAffected- 傳回{受影響的Rows(INSERT,UPDATE,DELETE)|原值(SELECT)} *
'* strConnectString - ADO連結資料庫的連結字串 *
'* Return - {Recordset(SELECT)|Nothing(INSERT,DELETE,UPDATE)} *
'**************************************************************************************************
Public Function Execute(ByVal strSQL As String _
, Optional ByRef lngRecordAffected As Variant _
, Optional ByVal strConnectString As String) As ADODB.Recordset
Const METHOD_NAME As String = CLASS_NAME & "Execute()"
Dim strErr As String
On Error GoTo ErrHandler
Set Execute = GetClientRS(strConnectString, adOpenStatic, strSQL, 0)
lngRecordAffected = mlngRA
mlngRA = 0
Exit FunctionErrHandler:
strErr = HandleErr()
Err.Raise ERR_NO_BASE, METHOD_NAME, strErr
End Function'**************************************************************************************************
'* 參數： *
'* - strConnectString = ADO連結資料庫的連結字串 *
'* - lngCursorType = 這個參數沒有用到(為防止Client造成Connection Leak一律使用adOpenStatic) *
'* - strSQL = {SQL statement(INSERT,UPDATE,DELETE,SELECT)|Stored-Procedure call} *
'* - lngMaxRecords = 這個參數沒有用到 *
'* *
'* 傳回值： *
'* - Recordset{SELECT|Stored-Procedure} *
'* - Nothing {INSERT|DELETE|UPDATE} *
'* *
'* Stored-Procedure Call Example： *
'* - Query_Contract '','','LL','','','','A123456789','','','','',"Contract_all.Contract_Serial_Num,Contract_all.Product_type,Customer_C_Name,Line_ID,BSCS_Contract_ID,contract_status,Cont","ract_all.Data_Create_CSR,Contract_all.Data_Create_date,Contract_all.LOCK_FLAG","2000" *
'* - Query_Contract is Oracle package name *
'* - The stored-procedure name "GetQueryData" is hard-coded *
'**************************************************************************************************
Public Function GetServerRS(ByVal strConnectString As String _
, ByVal lngCursorType As Long _
, ByVal strSQL As String _
, ByVal lngMaxRecords As Long) As ADODB.Recordset
Const METHOD_NAME As String = CLASS_NAME & "GetServerRS()"
Dim strErr As String
On Error GoTo ErrHandler
Set GetServerRS = GetClientRS(strConnectString, lngCursorType, strSQL, lngMaxRecords)
Exit FunctionErrHandler:
strErr = HandleErr()
Err.Raise ERR_NO_BASE, METHOD_NAME, strErr
End Function'**************************************************************************************************
'* 參數： *
'* - strConnectString = ADO連結資料庫的連結字串 *
'* - lngCursorType = 這個參數沒有用到(為防止Client造成Connection Leak一律使用adOpenStatic) *
'* - strSQL = {SQL statement(INSERT,UPDATE,DELETE,SELECT)|Stored-Procedure call} *
'* - lngMaxRecords = 這個參數沒有用到 *
'* *
'* 傳回值： *
'* - Recordset{SELECT|Stored-Procedure} *
'* - Nothing {INSERT|DELETE|UPDATE} *
'* *
'* Stored-Procedure Call Example： *
'* - Query_Contract '','','LL','','','','A123456789','','','','',"Contract_all.Contract_Serial_Num,Contract_all.Product_type,Customer_C_Name,Line_ID,BSCS_Contract_ID,contract_status,Cont","ract_all.Data_Create_CSR,Contract_all.Data_Create_date,Contract_all.LOCK_FLAG","2000" *
'* - Query_Contract is Oracle package name *
'* - The stored-procedure name "GetQueryData" is hard-coded *
Public Function GetClientRS(ByVal strConnectString As String _
, ByVal lngCursorType As Long _
, ByVal strSQL As String _
, ByVal lngMaxRecords As Long) As ADODB.Recordset
Const METHOD_NAME As String = CLASS_NAME & "GetClientRS()"
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim cm As ADODB.Command
Dim strCmdType As String '{INSERT|UPDATE|DELETE|STORED-PROCEDURE Package Name}
Dim IsOraOLEDB As Boolean
Dim strErr As String
Dim i As Integer
On Error GoTo ErrHandler
'Prepare Connection String
strConnectString = Trim$(strConnectString & "")
If strConnectString = "" Then strConnectString = mstrCS
If InStr(1, strConnectString, "OraOLEDB.Oracle", vbTextCompare) <> 0 Then
strConnectString = Replace$(strConnectString, ";PLSQLRSet=1", "", 1, -1, vbTextCompare)
IsOraOLEDB = True
End If
strSQL = Trim$(strSQL & "")
i = InStr(1, strSQL, " ")
If i = 0 Then 'Stored-Procedure without parameters
strCmdType = strSQL
Else
strCmdType = UCase$(Left$(strSQL, i - 1))
End If
Set cn = New ADODB.Connection
Select Case strCmdType
Case "SELECT"
Set rs = New ADODB.Recordset
cn.CursorLocation = adUseClient
cn.Open strConnectString
rs.Open strSQL, cn, adOpenStatic, adLockReadOnly, adCmdText
Set rs.ActiveConnection = Nothing
Case "INSERT", "UPDATE", "DELETE"
cn.Open strConnectString
cn.Execute strSQL, mlngRA, adCmdText + adExecuteNoRecords
Case Else 'Stored-Procedure Call
'Prepare Connection String
If IsOraOLEDB Then
If InStr(1, strConnectString, "DistribTX", vbTextCompare) = 0 Then
If Right$(strConnectString, 1) <> ";" Then strConnectString = strConnectString & ";"
strConnectString = strConnectString & "DistribTX=0"
End If
End If
'Prepare Command
Set cm = New ADODB.Command
cm.CommandType = adCmdStoredProc
cm.CommandText = strCmdType & SP_NAME
ParseParameters cm, strCmdType, strSQL
'Prepare Recordset
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.CursorType = adOpenStatic
rs.LockType = adLockReadOnly
'Just In Time to Open Connection
cn.CursorLocation = adUseClient
cn.Open strConnectString
Set cm.ActiveConnection = cn
If IsOraOLEDB Then cm.Properties("PLSQLRSet") = True
rs.Open cm
Set cm = Nothing
Set rs.ActiveConnection = Nothing
End Select
cn.Close
Set cn = Nothing
Set GetClientRS = rs
Set rs = Nothing
Exit FunctionErrHandler:
strErr = HandleErr(cn, rs, cm)
Err.Raise ERR_NO_BASE, METHOD_NAME, strErr
End Function
'Parse parameter(s) of Stored-Procedure
'And add to Command object's Parameter Collection
'cm - ADO Command object
'strCmdType - Stored-Procedure package name
'S - Client Stored-Procedure call string
Private Sub ParseParameters(ByRef cm As ADODB.Command _
, ByRef strCmdType As String _
, ByRef S As String)
Const METHOD_NAME As String = CLASS_NAME & "ParseParameters()"
Dim lngB As Long
Dim lngE As Long
Dim lngLen As Long
Dim strBegChar As String
Dim strEndChar As String
Dim strParameter As String
Dim i As Long
S = Trim$(Mid$(S, Len(strCmdType) + 2)) 'Strip the stored-procedure package name
If S = "" Then Exit Sub 'no parameters
lngB = 1
lngLen = Len(S)
Do While lngB <= lngLen
strBegChar = Mid$(S, lngB, 1)
Select Case strBegChar
Case "'", """" 'VarChar2
strEndChar = strBegChar
Case Else 'Integer
strEndChar = ","
End Select
lngE = FindEndChar(S, lngB + 1, lngLen, strEndChar)
If lngE = 0 Then
If strEndChar = "," Then '{Only one|The last} integer parameter
lngE = lngLen + 1
Else 'Sigle/Double quote has no end char
Err.Raise ERR_SYN, METHOD_NAME, ERR_SYN_DESC
End If
End If
If strEndChar = "," Then lngE = lngE - 1 'Always position before "," char
strParameter = Trim$(Mid$(S, lngB, lngE - lngB + 1))
AddParameter cm, strParameter
If lngE >= lngLen Then 'No more parameter so make exit condition true
lngB = lngLen + 1
Else
lngB = InStr(lngE + 1, S, ",", vbBinaryCompare) + 1 'Skip the first next "," char
For i = lngB To lngLen 'Skip SPACE and position at the first next NON-SPACE char
If Mid$(S, i, 1) <> Space(1) Then
lngB = i
Exit For
End If
Next i
If Mid$(S, lngB, 1) = "," Then 'Syntax "~,,~" not allow
Err.Raise ERR_SYN, METHOD_NAME, ERR_SYN_DESC
End If
End If
Loop
End Sub
Private Function FindEndChar(ByRef S As String _
, ByVal lngBeg As Long _
, ByRef lngLen As Long _
, ByRef strChar As String) As Long
Dim strTemp As String
Do While lngBeg <= lngLen
strTemp = Mid$(S, lngBeg, 1)
If strTemp = strChar Then
If strChar = "," Then
Exit Do
Else
If Mid$(S, lngBeg + 1, 1) = strChar Then
lngBeg = lngBeg + 1 'Character Stuffing so skip
Else
Exit Do
End If
End If
End If
lngBeg = lngBeg + 1
Loop
If lngBeg > lngLen Then FindEndChar = 0 Else FindEndChar = lngBeg
End FunctionPrivate Sub AddParameter(ByRef cm As ADODB.Command, ByRef strParameter As String)
Select Case Left$(strParameter, 1)
Case "'", """" 'VarChar2
If Len(strParameter) = 2 Then '{''|""}
cm.Parameters.Append cm.CreateParameter(, adVarChar, adParamInput, 1, "")
Else
cm.Parameters.Append cm.CreateParameter(, adVarChar, adParamInput, Len(strParameter) - 2, Mid$(strParameter, 2, Len(strParameter) - 2))
End If
Case Else 'Integer
cm.Parameters.Append cm.CreateParameter(, adInteger, adParamInput, , strParameter)
End Select
End SubPrivate Sub Class_Initialize()
'Read Default Connect String from Registry
Dim r As EBTUtility.Registry
Set r = CreateObject("EBTUtility.Registry")
mstrCS = r.GetKeyValue(REG_CONNECT_STRING)
Set r = Nothing
End Sub