' ---------------------------------------------------------------------------- ' File: $RCSfile: LD.BAS $ ' Author: $Author: rclewley $ ' Date: $Date: 1998/09/08 14:16:52 $ ' Version: $Revision: 1.1 $ ' Status: $State: Exp $ ' Locked_by: $Locker: $ ' Description: ' Notes: ' RealAuth: ' IncepDate: ' Copyright: (c) Oracle Corporation 1998. All Rights Reserved. ' ---------------------------------------------------------------------------- ' Log of Changes from RCS ' ---------------------------------------------------------------------------- ' $Log: LD.BAS $ ' Revision 1.1 1998/09/08 14:16:52 rclewley ' Initial revision ' ' ---------------------------------------------------------------------------- ' Attribute VB_Name = "LD" Option Explicit ' Private and public constants for database specific AOF 'Connection Information Public gstrUserName As String Public gstrPassword As String Public gstrDatabaseName As String ' Session information Public gSession As OraSession Public gDatabase As OraDatabase ' Retry counters Const ROW_LOCK_RETRY = 4 Const STOP_RETRY = 6 ' Oracle error codes Global Const gORA_ERROR_ROW_LOCKED = 54 Global Const ORA_ERROR_INVALID_UNPW = 1017 Const ORA_ERROR_TABLE_NOEXIST = 942 Global Const ORA_ERROR_ORACLE_NOT_AVAIL = 1034 ' SQL Keywords Global Const gSQL_KEYWD_SELECT = "SELECT " Global Const gSQL_KEYWD_SELECT_DISTINCT = "SELECT DISTINCT " Global Const gSQL_KEYWD_ISNULL = "IS NULL" Global Const gSQL_KEYWD_IS_NOTNULL = "IS NOT NULL" Global Const gSQL_KEYWD_LIKE = "LIKE" Global Const gSQL_KEYWD_WHERE = " WHERE " Global Const gSQL_KEYWD_AND = " AND " Global Const gSQL_KEYWD_OR = " OR " Global Const gSQL_KEYWD_BETWEEN = " BETWEEN " Global Const gSQL_KEYWD_FROM = " FROM " Global Const gSQL_KEYWD_ORDER_BY = " ORDER BY " Global Const gSQL_KEYWD_FOR_UPDATE = " FOR UPDATE" Global Const gSQL_KEYWD_NOWAIT = " NOWAIT" Global Const gSQL_KEYWD_DESC = " DESC" Global Const gSQL_KEYWD_WILDCHAR = "%" ' Read only dynaset option Global Const gREAD_ONLY_OPT = 4 ' Error handler Global Const gEND_EVENT = 32767 ' Stirng constant for Domain parameter Global Const gDOMAIN_PARAM = "Domain" Global Const gCODE_PARAM = "Code" ' Database parameter IOType option one ' (parameter used as an input variable) Const PARAM_IOTYPE_OPT_I = 1 ' ' Private constants for the Server Errors AOF. These determine the ' make up of an Oracle Error Message. The format of a message ' is as follows ' ORA-nnnnn: xxxxx (yyyyy.zzzzz) xxxxx ' where nnnnn is a zero padded five digit number ' xxxxx is a character string ' yyyyy is the schema name in a constraint violation ' zzzzz is the constraint name in a constraint violation Const SE_MSG_PREFIX = "ORA-" ' The product prefix Const SE_MSG_CODE_SEP = ":" ' Prefix and message separator Const SE_CONSTR_START = "(" ' Start character of the constraint name Const SE_CONSTR_END = ")" ' End character of the constraint name Const SE_CONSTR_SEP = "." ' Schema and constraint name separator ' Private constants for Oracle For Objects errors Const OIP_MSG_PREFIX = "OIP-" Const OIP_MSG_CODE_SEP = ":" ' Message separator ' ' Public constants for the Server Errors AOF. These map the error codes ' returned by the server to constraint violation types. For example ' Oracle Error 00001 maps to a primary/unique constraint violation. Global Const gSE_ORAERR_NO_ERROR = 0 Global Const gSE_ORAERR_UNIQUE_CONSTRAINT = 1 Global Const gSE_ORAERR_CHECK_CONSTRAINT = 2290 Global Const gSE_ORAERR_FK_NO_PARENT = 2291 Global Const gSE_ORAERR_FK_CHILD_FOUND = 2292 Global Const gSE_ORAERR_APP_ERROR_LOW = 20000 Global Const gSE_ORAERR_APP_ERROR_HIGH = 20999 Global Const gSE_ORAERR_RECURSIVE_SQL = 604 ' ' Private constants for the Domain Validation AOF. ' ' Maximum number of rows to be displayed in the LOV Const DV_LOV_MAX_ROWS = 500 ' Spacing between the refcode and meaning when populating a list control. Global Const gDV_LIST_COL_SPACING = " " ' String constants for unknown option in allowed values list Const DV_UNKNOWN_LOV_OPT_CODE = "!" ' For LOVs we hold an array of LOV forms currently in use. These ' variables are used by the ldLOV* routines. Private maLOVForms() As New frmldLOV Private maLOVIsLoaded() As Integer Private mintLOVFormCount As Integer ' Constants for use in a call to domain list population to represent ' how nulls should be handled ' Global Const gNO_UNKNOWN = 1 Global Const gUNKNOWN = 2 Global Const gQD_UNKNOWN = 3 ' Form level dynaset for resequence up/down Private mdysSwap As OraDynaset Public Function ldQDBuildLiteral(pvarValue As Variant, ByVal pstrDtype As String) As Variant ' ' DESCRIPTION ' This function constructs a literal value to use in the ' where clause of a query. ' ' PARAMETERS ' pVarValue IN The value to be validated ' pstrDtype IN The datatype of the user entry control ' RETURN VALUE ' Variant - The literal value If (pstrDtype = "C") Then ldQDBuildLiteral = "'" & pvarValue & "'" ElseIf pstrDtype = "D" Then ' Convert the date to standard format ldQDBuildLiteral = "'" & Format$(pvarValue, "dd-mmm-yyyy") & "'" Else ldQDBuildLiteral = pvarValue End If End Function Public Function ldGetUserLogonInfo() As String ' ' DESCRIPTION ' This function returns information about the logged on user/database ' for display in the about box. ' ' RETURNS ' String describing the connection information On Error GoTo ldGetUserLogonInfoErr ldGetUserLogonInfo = glmaUSER & gstrUserName & "@" & gstrDatabaseName Exit Function ldGetUserLogonInfoErr: ldGetUserLogonInfo = "" Exit Function End Function Public Function ldGetDataAccessInfo() As String ' ' DESCRIPTION ' This function returns information about the data access method, for ' display in the about box. ' ' RETURNS ' String describing the data access method On Error GoTo ldGetDataAccessInfoErr ldGetDataAccessInfo = glmaSERVER & gSession.OipVersionNumber Exit Function ldGetDataAccessInfoErr: ldGetDataAccessInfo = "" Exit Function End Function Sub ldStatusUserLogon(pctlStatusUser As Control) ' ' DESCRIPTION ' This routine sets the Caption of the given control to the ' current user logged on ' ' PARAMETERS ' pctlStatusUser IN The control to be set On Error GoTo ldStatusUserLogonErr ' If frmldLogon.ldCreateSession has set up user/database info, ' then use that. Otherwise, take info from database object pctlStatusUser.Caption = " User: " & gstrUserName & "@" & gstrDatabaseName Exit Sub ldStatusUserLogonErr: pctlStatusUser.Caption = "" Exit Sub End Sub Function ldDeleteRow(ByVal pstrTableName As String, ByVal pstrWhere As String, ByVal pstrColumn As String, _ pintErrNum As Integer, pstrMsgStack As String, pstrSql As String, pintErrPos As Integer) As Boolean ' ' DESCRIPTION ' Deletes the row from the given table identified by the given WHERE clause. ' If it fails to delete the row because either no row found, or row is ' locked then it displays a message and returns false. If any other server ' error occurs, it returns false and passes back to the caller the message ' along with the SQL statement issued, for the caller to handle. ' The caller must also handle starting and closing the transaction. ' ' PARAMETERS ' pstrTableName IN The table from which to delete the row ' pstrWhere IN The where clause to isolate the row to be deleted ' pstrColumn IN The column to use in the select statement, so to allow the dynaset to be updateable ' pintErrNum OUT The Error number returned from the server ' pstrMsgStack OUT The SQL error message returned from the server ' pstrSql OUT SQL statement issued to the server ' pintErrPos OUT The SQL error position returned from the server ' ' RETURNS ' True - The row was deleted ' False - The row was not deleted ' ' EXAMPLE USAGE ' If ldTransactionBegin() Then ' If ldDeleteRow("DEPT", strWhere, "DEPTNO", intErrNum, strSQLErrMsg, strSql, intErrPos) Then ' If ldTransactionCommit() Then ' Call lgMsg("Row deleted", gMG_SEV_INFO) ' End If ' Else ' Call ldTransactionRollback ' If strSQLErrMsg != "" Then ' bhandled = DeptServErrors("cmdDelete", intErrNum, strSQLErrMsg, strSql, intErrPos) ' End If ' End If ' End If ' Dim strSql As String Dim dysDelete As OraDynaset On Error GoTo ldDeleteRow_Err ' Assume that the row could not be deleted ldDeleteRow = False ' Initialise the output parameters pstrMsgStack = "" pstrSql = "" pintErrPos = 0 ' Construct the SQL statement strSql = gSQL_KEYWD_SELECT & pstrColumn & gSQL_KEYWD_FROM & pstrTableName & gSQL_KEYWD_WHERE & pstrWhere strSql = strSql & gSQL_KEYWD_FOR_UPDATE & gSQL_KEYWD_NOWAIT ' Clear the session error buffer before database operation gDatabase.LastServerErrReset ' Create the dynaset from the constructed SQL Set dysDelete = gDatabase.DbCreateDynaset(strSql, 0) ' If the dynaset contains no rows then ' inform the user that the record has already been deleted. If dysDelete.EOF Then Call lgMsg(glmtRECORD_NO_LONGER_EXISTS, gMG_SEV_ERROR) Exit Function End If ' Delete the row dysDelete.DbDelete ' The row was deleted ldDeleteRow = True Exit Function ldDeleteRow_Err: ' Handle OLE Automation error (Row locked) with a user friendly message, ' other OLE Automation errors with ServerError dialog, and pass back a VB error for all else. If gDatabase.LastServerErr <> 0 Then If gDatabase.LastServerErr = gORA_ERROR_ROW_LOCKED Then Call lgMsg(glmtROW_LOCKED, gMG_SEV_WARN) Else pintErrNum = gDatabase.LastServerErr pstrMsgStack = gDatabase.LastServerErrText pstrSql = strSql pintErrPos = gDatabase.LastServerErrPos End If Exit Function Else Call lgMsgVBError("LD.BAS", "ldDeleteRow", Err) Exit Function End If End Function Sub ldDVPopulateDom(ByVal pstrTableName As String, ByVal pstrDomain As String, ByVal pbIncMean As Integer, _ ByVal pintAddUnknown As Integer, paDomain() As lgDomain) ' ' DESCRIPTION ' This routine populates the specified domain array, with the allowed values ' aabbreviations, and meanings (optionally) from the given table, for the given domain. ' There is a parameter option to display the extra list choice for an unknown ' value. ' This procedure will be called by generated code. ' ' PARAMETERS ' pstrTableName IN Table name from which to obtain values ' pstrDomain IN Domain name from which to obtain values ' pbIncMean IN Boolean value to denote whether to include the meaning in the list ' pbAddUnknown IN Boolean value to denote whether to add an 'unknown' option to the list ' paDomain() OUT The domain array to be populated Dim dysRefCodes As OraDynaset Dim strSql As String Dim i, intArraySize As Integer On Error GoTo ldDVPopulateDom_Err ' Set the domain parameter to the given domain value Call ldSetParamVal(gDOMAIN_PARAM, "C", pstrDomain) ' Construct the SQL statement strSql = gSQL_KEYWD_SELECT & "RV_LOW_VALUE, RV_MEANING, RV_ABBREVIATION" & gSQL_KEYWD_FROM & pstrTableName & gSQL_KEYWD_WHERE & "RV_DOMAIN = " & ":" & gDOMAIN_PARAM ' Clear the session error buffer before database operation gDatabase.LastServerErrReset ' Create a read-only dynaset from the constructed SQL Set dysRefCodes = gDatabase.DbCreateDynaset(strSql, gREAD_ONLY_OPT) If dysRefCodes.EOF Then ' If no rows in ref codes, give a warning Call lgMsg(lgMsgSubst(glmdNO_DV_ROWS_FOUND, pstrTableName & "/" & pstrDomain), gMG_SEV_WARN) ReDim paDomain(0) As lgDomain Exit Sub Else ' Re-set the size of the domain array dysRefCodes.DbMoveLast intArraySize = dysRefCodes.RecordCount If pintAddUnknown <> gNO_UNKNOWN Then intArraySize = intArraySize + 1 End If ReDim paDomain(intArraySize - 1) As lgDomain dysRefCodes.DbMoveFirst i = LBound(paDomain) End If ' Construct a display string for each row in the dynaset, ' then populate the list control with these values. Dim strCodeField As String Dim strMeanField As String Dim strAbbrField As String Dim strRow As String Dim varAbbrev As Variant Dim varMean As Variant Do While Not dysRefCodes.EOF strCodeField = dysRefCodes("RV_LOW_VALUE") varAbbrev = dysRefCodes("RV_ABBREVIATION") varMean = dysRefCodes("RV_MEANING") ' Include the meaning in the array if pbIncMean is true ' and add the abbreviation, defaulting to the code if displaying ' meanings If pbIncMean Then strMeanField = lgNvl(varMean, strCodeField) strAbbrField = lgNvl(varAbbrev, strCodeField) Else strMeanField = "" strAbbrField = lgNvl(varAbbrev, "") End If ' If there is a code then construct the display string If strCodeField <> "" Then paDomain(i).Value = strCodeField paDomain(i).Abbrev = strAbbrField 'If Meaning_Alongside Then ' paDomain(i).Meaning = paDomain(i).Value + " " + strMeanField 'Else paDomain(i).Meaning = strMeanField 'End If i = i + 1 End If dysRefCodes.DbMoveNext Loop ' If required, add row for the Unknown option If pintAddUnknown = gUNKNOWN Then paDomain(i).Value = "" paDomain(i).Abbrev = "" paDomain(i).Meaning = "" ElseIf pintAddUnknown = gQD_UNKNOWN Then paDomain(i).Value = gSQL_KEYWD_ISNULL paDomain(i).Abbrev = gSQL_KEYWD_ISNULL paDomain(i).Meaning = gSQL_KEYWD_ISNULL End If Exit Sub ldDVPopulateDom_Err: If gDatabase.LastServerErr <> 0 Then Call lgMsgServerError("LDDV.BAS", "ldDVPopulateDom", CInt(gDatabase.LastServerErr), CStr(gDatabase.LastServerErrText), strSql, CInt(gDatabase.LastServerErrPos)) Exit Sub Else Call lgMsgVBError("LD.BAS", "ldDVPopulateDom", Err) End If End Sub Function ldGetOIPErr(ByVal pstrErrMsg As String) As Integer ' ' DESCRIPTION ' This function returns the error code from the given ' Oracle Objects error message. If an error code was not found, ' it returns zero. ' ' PARAMETER ' pstrErrMsg IN The error message to strip the error number from ' ' RETURN VALUE ' Integer - The error code found Dim intStartPos As Integer ' Find the start of the error number intStartPos = InStr(pstrErrMsg, OIP_MSG_PREFIX) If (intStartPos <> 0) Then ' Error number found, so strip it and return ldGetOIPErr = CInt(Mid(pstrErrMsg, intStartPos + Len(OIP_MSG_PREFIX), InStr(intStartPos, pstrErrMsg, OIP_MSG_CODE_SEP) _ - intStartPos - Len(OIP_MSG_PREFIX))) Else ' An error number was not found ldGetOIPErr = 0 End If End Function Function ldLOVDefine(ByVal pstrName As String, ByVal pstrTitle As String, _ ByVal pintMaxRows As Integer, ByVal pstrFrom As String, _ ByVal pstrWhere As String, ByRef pbNewForm As Boolean, _ Optional pintWidth, Optional pbDistinct) As frmldLOV ' ' DESCRIPTION ' This function 'defines' an LOV by adding an entry into the list of loaded ' LOV forms (if not already present) and passing in the parameters into ' the LOV form. ' ' PARAMETERS ' pstrName IN The name used to uniquely identify the LOV ' pstrTitle IN Title for the LOV window ' pintMaxRows IN Maximum rows we should fetch from the server ' If zero passed in, assume default value ' pstrFrom IN SQL FROM clause to use in query SQL ' pstrWhere IN SQL WHERE clause to use in query SQL ' pintWidth IN The width of the LOV (in characters) ' pbNewForm OUT Was a new form created ' ' RETURNS ' The LOV Form Dim intEmptySlot As Integer ' Empty slot in LOV forms array ' Initialise the output parameter Set ldLOVDefine = Nothing pbNewForm = False Dim i As Integer intEmptySlot = -1 ' -1 Indicates no empty slot available ' Check to see if this LOV is already known / loaded, and if ' not, find the next empty slot available For i = 0 To mintLOVFormCount - 1 If maLOVIsLoaded(i) Then If maLOVForms(i).mstrUniqueName = pstrName Then Set ldLOVDefine = maLOVForms(i) pbNewForm = False Exit Function End If Else If intEmptySlot = -1 Then intEmptySlot = i End If Next i ' LOV not defined. If no empty slot is available, then extend ' the LOV forms array to add the new entry If intEmptySlot = -1 Then intEmptySlot = mintLOVFormCount mintLOVFormCount = mintLOVFormCount + 1 ReDim Preserve maLOVForms(mintLOVFormCount) pbNewForm = True ReDim Preserve maLOVIsLoaded(mintLOVFormCount) End If ' Initialise all the input parameters on the form Call maLOVForms(intEmptySlot).InitialiseForm(pstrName, _ pstrTitle, pintMaxRows, pstrFrom, pstrWhere, pintWidth, pbDistinct) ' Note that this slot is in use maLOVIsLoaded(intEmptySlot) = True ' Set the out parameter Set ldLOVDefine = maLOVForms(intEmptySlot) End Function Sub ldLOVUnLoad(ByVal pstrName As String) ' ' DESCRIPTION ' Unloads the given LOV from memory ' ' PARAMETERS ' pstrName IN The name used to define the LOV Dim i As Integer ' Loop through the LOVs loaded in memory. If we find the ' LOV with the given name, then unload it. For i = 0 To mintLOVFormCount - 1 If maLOVIsLoaded(i) Then If maLOVForms(i).mstrUniqueName = pstrName Then maLOVIsLoaded(i) = False Unload maLOVForms(i) Set maLOVForms(i) = Nothing Exit For End If End If Next i End Sub Function ldNextIdCC(ByVal pstrTableName As String, ByVal pstrDomain As String) As Long ' ' DESCRIPTION ' This function returns the current sequence number for the sequence table ' and domain specified, and updates the sequence by one. ' ' PARAMETERS ' pstrTableName IN The name of the table from which the sequence is to be obtained ' pstrDomain IN The name of the domain from which the sequence is to be obtained ' ' RETURNS ' 0 - If unable to lock the table or an error occurs ' Integer - The sequence number obtained Dim strLHS As String Dim strWhere As String Dim strRHS As String Dim strSql As String Dim intRetry As Integer Dim dysSeqId As OraDynaset Dim intRowlocked As Integer ' Assume that the function was unable to lock the row intRowlocked = False On Error GoTo ldNextIdCC_Err ' If a tableName has been supplied then construct the select statement ' otherwise return 0 and exit the function. If pstrTableName <> "" Then ' Set the domain parameter to the given domain value Call ldSetParamVal(gDOMAIN_PARAM, "C", pstrDomain) ' Create the SQL statement strLHS = "Select CC_NEXT_VALUE from " & pstrTableName If pstrDomain <> "" Then strWhere = " where CC_DOMAIN = " & ":" & gDOMAIN_PARAM End If Else ldNextIdCC = 0 Call lgMsg(glmdNULL_TABLENAME, gMG_SEV_ERROR) Exit Function End If strRHS = " for update of CC_NEXT_VALUE nowait" strSql = strLHS & strWhere & strRHS Do While intRetry < STOP_RETRY ' Clear the session error buffer before database operation gDatabase.LastServerErrReset ' Create dynaset to execute SQL statement Set dysSeqId = gDatabase.DbCreateDynaset(strSql, 0) ' If row is locked, retry a number of times before providing ' the user with a message. If (gDatabase.LastServerErr = gORA_ERROR_ROW_LOCKED) Then If intRetry > ROW_LOCK_RETRY Then Call lgMsg(lgMsgSubst(glmdNO_LOCK, pstrTableName), gMG_SEV_WARN) ldNextIdCC = 0 ' Reset mousepointer back to default Screen.MousePointer = vbDefault Exit Function Else ' Set the retry count intRetry = intRetry + 1 ' Sleep for a second Dim varStart As Variant varStart = Timer Do Until Timer >= varStart + 1 Loop End If ' If table not found ElseIf (gDatabase.LastServerErr = ORA_ERROR_TABLE_NOEXIST) Then Call lgMsg(lgMsgSubst(glmdTABLE_NOT_SETUP, pstrTableName), gMG_SEV_FATAL) ldNextIdCC = 0 ' Reset mousepointer back to default Screen.MousePointer = vbDefault Exit Function ' Dynaset was created Else intRowlocked = True Exit Do End If Loop ' If dynaset was successfully created If intRowlocked = True Then ' Initialise the data dysSeqId.DbMoveFirst Dim intSeqNum As Integer ' If the dynaset is empty (domain caused no rows to be returned) ' then provide the user with a simple message. If IsNull(dysSeqId("CC_NEXT_VALUE")) Then ldNextIdCC = 0 If pstrDomain <> "" Then Call lgMsg(lgMsgSubst(glmdNO_CC_ROWS_FOUND, pstrTableName & "/" & pstrDomain), gMG_SEV_ERROR) Else Call lgMsg(lgMsgSubst(glmdNO_CC_ROWS_FOUND, pstrTableName), gMG_SEV_ERROR) End If ' Reset the mousepointer Screen.MousePointer = vbDefault Exit Function ' If dynaset is not empty then return the sequence number ' and update the table (add one to the sequence). Else intSeqNum = dysSeqId("CC_NEXT_VALUE") ldNextIdCC = intSeqNum dysSeqId.DbEdit dysSeqId("CC_NEXT_VALUE").Value = intSeqNum + 1 dysSeqId.DbUpdate End If End If Exit Function ldNextIdCC_Err: ' Handle OLE Automation errors (Row lock & Table not exist) in the body of the function, ' other OLE Automation errors with ServerError dialog, and pass back a VB error for all else. If gDatabase.LastServerErr <> 0 Then If gDatabase.LastServerErr = gORA_ERROR_ROW_LOCKED Then Resume Next ElseIf gDatabase.LastServerErr = ORA_ERROR_TABLE_NOEXIST Then Resume Next Else Call lgMsgServerError("LD.BAS", "ldNextIdCC", CInt(gDatabase.LastServerErr), CStr(gDatabase.LastServerErrText), _ strSql, CInt(gDatabase.LastServerErrPos)) Exit Function End If Else Call lgMsgVBError("LD.BAS", "ldNextIdCC", Err) Exit Function End If End Function Function ldNextIdSeq(ByVal pstrSeqName As String) As Long ' ' DESCRIPTION ' This function returns the current sequence number from the sequence ' specified. ' ' PARAMETERS ' pstrSeqName IN The name of the sequence from which the sequence number is to be obtained ' ' RETURNS ' Zero - If an error occurs ' Integer - The Sequence number obtained Dim strSql As String Dim dysSeq As OraDynaset ' Assume that the function was unsuccessfull ldNextIdSeq = 0 ' Create a dynaset from the constructed SQL, and ' return the next sequence number. ' If there's an error return 0 and exit the function. On Error GoTo ldNextIdSeq_Err strSql = gSQL_KEYWD_SELECT & pstrSeqName & ".nextval from sys.dual" ' Clear the session error buffer before the database operation gDatabase.LastServerErrReset ' Create the dynaset Set dysSeq = gDatabase.DbCreateDynaset(strSql, 0) ldNextIdSeq = dysSeq("NEXTVAL") Exit Function ldNextIdSeq_Err: If gDatabase.LastServerErr <> 0 Then Call lgMsgServerError("LD.BAS", "ldNextIdSeq", CInt(gDatabase.LastServerErr), CStr(gDatabase.LastServerErrText), strSql, _ CInt(gDatabase.LastServerErrPos)) Else Call lgMsgVBError("LD.BAS", "ldNextIdSeq", Err) End If Exit Function End Function Sub ldSetParamVal(ByVal pstrParamName As String, ByVal pstrDataType As String, ByVal pvarValue As Variant) ' ' DESCRIPTION ' This procedure is responsible for setting the value and datatype ' of the given database parameter, to the given value and datatype. ' If the domain parameter does not already exist, it is created. ' ' PARAMETERS ' pstrParamName IN The name of the parameter to be set ' pstrDataType IN The datatype of the parameter to be set ' pvarValue IN The value to assign to the parameter Dim bParam_Exists As Integer Dim intDataType As Integer Dim varSetValue As Variant ' If a date, then convert it into Oracle standard format If pstrDataType = "D" Then varSetValue = Format(pvarValue, "DD-MMM-YYYY HH:MM:SS") Else varSetValue = pvarValue End If ' Set the given parameter to the given value bParam_Exists = True On Error GoTo ldSetParamVal_Err ' Clear the database error buffer before database operation gDatabase.LastServerErrReset gDatabase.Parameters(pstrParamName).Value = varSetValue On Error GoTo 0 ' If the parameter does not already exist ' create it with the given name for the given value. If Not bParam_Exists Then gDatabase.LastServerErrReset On Error GoTo ldCreateParam_Err gDatabase.Parameters.Add pstrParamName, Null, PARAM_IOTYPE_OPT_I If Not IsNull(varSetValue) Then gDatabase.Parameters(pstrParamName).Value = varSetValue End If End If ' Get the parameter type constant Select Case pstrDataType Case "N" intDataType = ORATYPE_NUMBER Case "D" intDataType = ORATYPE_DATE Case Else intDataType = ORATYPE_VARCHAR2 End Select ' Set the parameter type gDatabase.Parameters(pstrParamName).ServerType = intDataType Exit Sub ' If there is an OLE Automation error when setting the parameter value, ' it is assumed that this is due to the parameter not existing. ldSetParamVal_Err: bParam_Exists = False Resume Next ' There was a problem when creating the parameter ldCreateParam_Err: If gDatabase.LastServerErr <> 0 Then Call lgMsg(lgMsgSubst(glmdPARAM_FAIL, pstrParamName), gMG_SEV_FATAL) Error gEND_EVENT Else Call lgMsgVBError("LD.BAS", "ldSetParamVal", Err) Error gEND_EVENT End If End Sub Function ldSPResequence(ByVal pstrTableName As String, ByVal pstrWhere As String, ByVal pstrColumn As String, _ pctlList As Control, pvarArray() As Variant, pintErrNum As Integer, pstrMsgStack As String, _ pstrSql As String, pintErrPos As Integer) As Boolean ' ' DESCRIPTION ' Updates the database sequence of the rows left in the given list control, ' after row deletion. Creates a dynaset using the given table and WHERE clause. ' Also updates the sequence as mirrored in the given array. ' If it fails to update the row because either no row found, ' or row is locked then it displays a message and returns false. ' If any other server error occurs, it returns false and passes back to the ' caller the message along with the SQL statement issued, for the caller to handle. ' The caller must also handle starting and closing the transaction. ' ' PARAMETERS ' pstrTableName IN The table from which to update the row ' pstrWhere IN The where clause to isolate the row to be updated ' pstrColumn IN The column to use in the select statement, so to allow the dynaset to be updateable ' pctlList IN The list containing the rows to update ' pvarArray IN/OUT The sequence array to update ' pintErrNum OUT The error number returned from the server ' pstrMsgStack OUT The SQL error message returned from the server ' pstrSql OUT SQL statement issued to the server ' pintErrPos OUT The error position returned from the server ' ' RETURNS ' True - The row was updated ' False - The row was not updated ' ' EXAMPLE USAGE ' If ldTransactionBegin() Then ' If ldSPResequence("ORDER_LINE_ITEMS", strWhere, "ORDE_SEQUENCE", lst, maORDE_OrdeSequence, intErrNum, strSQLErrMsg, strSql) Then ' If ldTransactionCommit() Then End If ' Else ' Call ldTransactionRollback ' If strSQLErrMsg != "" Then ' bhandled = OrdeServErrors("cmdDelete", intErrNum, strSQLErrMsg, strSql) ' End If ' End If ' End If ' Dim strSql As String Dim dysUpdate As OraDynaset Dim i As Integer Dim intNotSel As Integer On Error GoTo ldSPResequence_Err ' Assume that the row could not be updated ldSPResequence = False ' Initialise the output parameters pstrMsgStack = "" pstrSql = "" pintErrPos = 0 ' Initialise the row not selected count intNotSel = 0 ' Construct the SQL statement strSql = gSQL_KEYWD_SELECT & pstrColumn & gSQL_KEYWD_FROM & pstrTableName & gSQL_KEYWD_WHERE & pstrWhere strSql = strSql & gSQL_KEYWD_FOR_UPDATE & gSQL_KEYWD_NOWAIT & gSQL_KEYWD_ORDER_BY & pstrColumn ' Clear the session error buffer before database operation gDatabase.LastServerErrReset ' Create the dynaset from the constructed SQL Set dysUpdate = gDatabase.DbCreateDynaset(strSql, 0) ' Update the sequence to parent values in the database. ' Go through the given list items and for each row ' that is not selected (has not been deleted, therefore ' needs updating) update the database value, and move to the ' next row in the dynaset (ready for the update of the ' next non-selected row). For i = 0 To pctlList.ListCount - 1 ' For each row that is not selected If pctlList.Selected(i) = False Then ' Count each row that is not selected intNotSel = intNotSel + 1 ' If the sequence needs updating If pvarArray(pctlList.ItemData(i)) <> (intNotSel) Then ' Avoid resequencing a row that has ' been deleted by another user If dysUpdate.EOF Then Exit For ' Update the database sequence dysUpdate.DbEdit dysUpdate(pstrColumn).Value = intNotSel dysUpdate.DbUpdate End If ' Move to the next row in the dynaset ' for each row that is not selected. dysUpdate.DbMoveNext End If Next i ' Once the rows have been successfully updated, update the ' corresponding in memory array. intNotSel = 0 For i = 0 To pctlList.ListCount - 1 ' For each row that is not selected If pctlList.Selected(i) = False Then ' Count each row that is not selected intNotSel = intNotSel + 1 ' If the sequence needs updating, update it If pvarArray(pctlList.ItemData(i)) <> (intNotSel) Then pvarArray(pctlList.ItemData(i)) = intNotSel End If End If Next i ' The row was updated ldSPResequence = True Exit Function ldSPResequence_Err: ' Handle OLE Automation error (Row locked) with a user friendly message, ' other OLE Automation errors with ServerError dialog, and pass back a VB error for all else. If gDatabase.LastServerErr <> 0 Then If gDatabase.LastServerErr = gORA_ERROR_ROW_LOCKED Then Call lgMsg(glmtROW_LOCKED, gMG_SEV_WARN) Else pintErrNum = gDatabase.LastServerErr pstrMsgStack = gDatabase.LastServerErrText pstrSql = strSql pintErrPos = gDatabase.LastServerErrPos End If Exit Function Else Call lgMsgVBError("LD.BAS", "ldSPResequence", Err) Exit Function End If End Function Function ldSPSwap(ByVal pstrTableName As String, ByVal pstrWhere As String, ByVal pstrColumn As String, _ pintErrNum As Integer, pstrMsgStack As String, pstrSql As String, pintErrPos As Integer) As Boolean ' ' DESCRIPTION ' Updates the database sequence of the current and previous rows of the given list control, ' on a resequence up event. Creates a dynaset using the given table and WHERE clause. ' If it fails to update the rows because either no rows found, ' or a row is locked then it displays a message and returns false. ' If any other server error occurs, it returns false and passes back to the ' caller the message along with the SQL statement issued, for the caller to handle. ' The caller must also handle starting and closing the transaction. ' ' PARAMETERS ' pstrTableName IN The table from which to update the row ' pstrWhere IN The where clause to isolate the rows to be updated ' pstrColumn IN The column to use in the select statement, so to allow the dynaset to be updateable ' pintErrNum OUT The error number returned from the server ' pstrMsgStack OUT The SQL error message returned from the server ' pstrSql OUT SQL statement issued to the server ' pintErrPos OUT The SQL error position returned from the server ' ' RETURNS ' True - The row was updated ' False - The row was not updated Dim strSql As String Dim bTransCancel As Boolean On Error GoTo ldSPSwap_Err ' Assume that a row could not be updated ldSPSwap = False ' Initialise the output parameters pstrMsgStack = "" pstrSql = "" pintErrPos = 0 ' Construct the SQL statement strSql = gSQL_KEYWD_SELECT & pstrColumn & gSQL_KEYWD_FROM & pstrTableName & gSQL_KEYWD_WHERE & pstrWhere ' Commence the database transaction If ldTransactionBegin() Then bTransCancel = True ' Clear the session error buffer before database operation gDatabase.LastServerErrReset ' Only create the dynaset if it doesn't already exist ' otherwise refresh it. If mdysSwap Is Nothing Then Set mdysSwap = gDatabase.DbCreateDynaset(strSql, 0) Else mdysSwap.SQL = strSql mdysSwap.DBRefresh End If ' Update the database sequence ' Note: We assign -1 to the first fields sequence ' to avoid the unique constraint error. ' We then swap the two sequences by setting ' the NEXT sequence to the first fields original ' sequence, and the first field to the NEXT fields ' original sequence. Dim intSeq1 As Integer Dim intSeq2 As Integer intSeq1 = mdysSwap(pstrColumn).Value mdysSwap.DbMoveNext ' Only update the sequences if the selected row exists ' otherwise inform the user that the row no longer ' exists on the database, and rollback the transaction. If Not mdysSwap.EOF Then intSeq2 = mdysSwap(pstrColumn).Value mdysSwap.DbEdit mdysSwap(pstrColumn).Value = intSeq1 mdysSwap.DbUpdate mdysSwap.DbMovePrevious mdysSwap.DbEdit mdysSwap(pstrColumn).Value = intSeq2 mdysSwap.DbUpdate ' The row was updated ldSPSwap = True ' Commit the transaction If ldTransactionCommit() Then bTransCancel = False End If Else Call lgMsg(glmtRECORD_NO_LONGER_EXISTS, gMG_SEV_ERROR) End If End If ldSPSwap_Exit: On Error GoTo 0 If bTransCancel Then Call ldTransactionRollback End If Exit Function ldSPSwap_Err: ' Handle OLE Automation error (Row locked) with a user friendly message, ' other OLE Automation errors with ServerError dialog, and pass back a VB error for all else. If gDatabase.LastServerErr <> 0 Then If gDatabase.LastServerErr = gORA_ERROR_ROW_LOCKED Then Call lgMsg(glmtROW_LOCKED, gMG_SEV_WARN) Else pintErrNum = gDatabase.LastServerErr pstrMsgStack = gDatabase.LastServerErrText pstrSql = strSql pintErrPos = gDatabase.LastServerErrPos End If Else Call lgMsgVBError("LD.BAS", "ldSPSwap", Err) End If Resume ldSPSwap_Exit End Function Function ldSrvErrConstraint(ByVal pstrErrMsg As String) As String ' ' DESCRIPTION ' This function finds the constraint name embedded in the error message ' text. It assumes that the error messages that contain constraint ' names are in the following format : ' ORA-xxxxx: xxxxx (schema_name.constraint_name) xxxxx ' ' PARAMETER ' pstrErrMsg IN The error message to check ' ' RETURNS ' String - That contains the constraint name embedded in the message ' Empty String - If the message did not contain a constraint name Dim intStartPos As Integer ' Find the position of the first opening bracket intStartPos = InStr(pstrErrMsg, SE_CONSTR_START) ' If the start of the constraint name was found, find the separator If (intStartPos <> 0) Then intStartPos = InStr(intStartPos, pstrErrMsg, SE_CONSTR_SEP) If (intStartPos <> 0) Then ' There was a separator, so strip the constraint name ldSrvErrConstraint = Mid(pstrErrMsg, intStartPos + 1, InStr(intStartPos, pstrErrMsg, SE_CONSTR_END) - intStartPos - 1) Else ' Did not find the separator, so return an empty string ldSrvErrConstraint = "" End If Else ' Did not find the start of the constraint name, so return an empty string ldSrvErrConstraint = "" End If End Function Function ldSrvErrGetErrNum(ByVal pstrErrMsg As String) As Integer ' ' DESCRIPTION ' This function returns the error code from the error message. If an error ' code was not found, it returns zero. ' ' PARAMETER ' pstrErrMsg IN The error message to strip the error number from ' ' RETURN VALUE ' Integer - The error code found Dim intStartPos As Integer ' Find the start of the error number intStartPos = InStr(pstrErrMsg, SE_MSG_PREFIX) If (intStartPos <> 0) Then ' Error number found, so strip it and return ldSrvErrGetErrNum = CInt(Mid(pstrErrMsg, intStartPos + Len(SE_MSG_PREFIX), InStr(intStartPos, pstrErrMsg, _ SE_MSG_CODE_SEP) - intStartPos - Len(SE_MSG_PREFIX))) Else ' An error number was not found ldSrvErrGetErrNum = 0 End If End Function Function ldSrvErrGetErrText(ByVal pstrMsgStack As String) As String ' ' DESCRIPTION ' This function returns the error message text of the error message at the ' top of the stack. ' ' PARAMETER ' pstrMsgStack IN The error stack to process ' ' RETURN VALUE ' String - The error message text of the first error on the stack Dim intEndPos As Integer Dim intStartPos As Integer ' Find the start of the error message text intStartPos = InStr(pstrMsgStack, SE_MSG_CODE_SEP) ' Find if there is more than one error in the string intEndPos = InStr(Len(SE_MSG_PREFIX), pstrMsgStack, SE_MSG_PREFIX) If (intEndPos <> 0) Then ' There was more than one error, so just return the error message ' text of the first error ldSrvErrGetErrText = Mid$(pstrMsgStack, intStartPos + 2, intEndPos - (intStartPos + 3)) Else ' Only one error, so return the error message text ldSrvErrGetErrText = Mid$(pstrMsgStack, intStartPos + 2) End If End Function Sub ldSrvErrPopStack(pstrMsgStack As String, pintErrCode As Integer) ' ' DESCRIPTION ' This routine removes the error message at the top of the error ' stack. If the stack is empty, an empty string is returned ' ' PARAMETERS ' pstrMsgStack IN OUT The message stack to process ' pintErrCode OUT The error number of the error message at the top of the ' stack Dim intStartPos As Integer ' Check if there is a more than one message on the stack intStartPos = InStr(Len(SE_MSG_PREFIX), pstrMsgStack, SE_MSG_PREFIX) If (intStartPos <> 0) Then ' More than one message was found, so remove the first pstrMsgStack = Mid$(pstrMsgStack, intStartPos) pintErrCode = ldSrvErrGetErrNum(pstrMsgStack) Else ' The stack is now empty. This situation should never occur since this ' routine is called to remove recursive SQL error messages. However, ' lets be tidy and signal the end of the stack to the caller pstrMsgStack = "" pintErrCode = 0 End If End Sub Function ldTransactionBegin() As Boolean ' ' DESCRIPTION ' This function begins a database transaction ' and handles any error that may occur. ' ' RETURNS ' True - The database transaction was started ' False - There was an error in starting the transaction ' Assume that the transaction will fail ldTransactionBegin = False On Error GoTo ldTransactionBegin_Err ' Begin the datatbase transaction gSession.DbBeginTrans ' The transaction was started ldTransactionBegin = True Exit Function ldTransactionBegin_Err: Call lgMsgVBError("LD.BAS", "ldTransactionBegin", Err) Exit Function End Function Function ldTransactionCommit() As Boolean ' ' DESCRIPTION ' This function commits the current transaction ' and handles any error that may occur. ' ' RETURNS ' True - The transaction was commited ' False - There was an error in commiting the transaction ' Assume that there will be an error ldTransactionCommit = False On Error GoTo ldTransactionCommit_Err ' Commit the current transaction gSession.DbCommitTrans ' The transaction was committed ldTransactionCommit = True Exit Function ldTransactionCommit_Err: If gDatabase.LastServerErr <> 0 Then Call lgMsgServerError("LD.BAS", "ldTransactionCommit", CInt(gDatabase.LastServerErr), CStr(gDatabase.LastServerErrText), "", 0) Else Call lgMsgVBError("LD.BAS", "ldTransactionCommit", Err) End If Exit Function End Function Sub ldTransactionRollback() ' ' DESCRIPTION ' This function rolls back the current transaction On Error GoTo ldTransactionRollBack_Err gSession.DbRollBack Exit Sub ldTransactionRollBack_Err: Call lgMsgVBError("LD.BAS", "ldTransactionRollBack", Err) Call lgMsg(glmdRESET_TRANS, gMG_SEV_WARN) gSession.DbResetTrans Exit Sub End Sub ' ' ---------------------------------------------------------------------------- ' $$Header_is_done ' End of file $RCSfile: LD.BAS $ ' ----------------------------------------------------------------------------