' ----------------------------------------------------------------------------
' File:        $RCSfile: lddao.bas $
' Author:      $Author: rclewley $
' Date:        $Date: 1998/09/08 14:16:55 $
' Version:     $Revision: 1.1 $
' Status:      $State: Exp $
' Locked_by:   $Locker:  $
' Description: <Enter global description here>
' Notes:       <Global notes>
' RealAuth:    <Full real name of code author>
' IncepDate:   <nnth Xxxember 1998>
' Copyright:   (c) Oracle Corporation 1998.  All Rights Reserved.
' ----------------------------------------------------------------------------
' Log of Changes from RCS
' ----------------------------------------------------------------------------
' $Log: lddao.bas $
' Revision 1.1  1998/09/08  14:16:55  rclewley
' Initial revision
'
' ----------------------------------------------------------------------------
'  
Attribute VB_Name = "LD"
Option Explicit


'Connection Information
Public gstrUserName As String
Public gstrPassword As String
Public gstrDatabaseName As String

' Logon/Connection information
Public gWorkspace As Workspace
Public gDatabase  As Database

' Retry counters
Const ROW_LOCK_RETRY = 4
Const STOP_RETRY = 6


' Visual Basic DAO error codes
Global Const gVB_ITEMS_NOT_FOUND = 3265      'dao error, object does not exist in collection
Global Const gVB_RECORD_DELETED = 3167       'record has been deleted by other user
Global Const gVB_DATA_HAS_CHANGED = 3197     'data has been changed by other user
Global Const gVB_RECORD_LOCKED = 3260        'could not update currently locked by other user
Global Const gVB_UPDATE_FAILED = 3157        'update failed on attached or linked table
' Read only dynaset option
Global Const gREAD_ONLY_OPT = 4


' SQL Keywords
Global Const gSQL_KEYWD_SELECT = "SELECT "
Global Const gSQL_KEYWD_SELECT_DISTINCT = "SELECT DISTINCTROW "
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_PARAMETERS = "PARAMETERS "
Global Const gSQL_KEYWD_LEFTJOIN = " LEFT JOIN "
Global Const gSQL_KEYWD_RIGHTJOIN = " RIGHT JOIN "
Global Const gSQL_KEYWD_INNERJOIN = " INNER JOIN "
Global Const gSQL_KEYWD_ON = " ON "
Global Const gSQL_KEYWD_DELETE = "DELETE "
Global Const gSQL_KEYWD_WILDCHAR = "*"

' Error handler
Global Const gEND_EVENT = 32767


' Public constants for different types of error returned by the database
' server (returned by ldErrorClass)
Global Const LD_ERROR_IS_NO_ERROR = 0
Global Const LD_ERROR_IS_ROW_LOCKED = 1
Global Const LD_ERROR_IS_TABLE_NOEXIST = 2
Global Const LD_ERROR_IS_UNIQUE_CONSTRAINT = 6
Global Const LD_ERROR_IS_CHECK_CONSTRAINT = 7
Global Const LD_ERROR_IS_FK_NO_PARENT = 8
Global Const LD_ERROR_IS_FK_CHILD_FOUND = 9
Global Const LD_ERROR_IS_UNKNOWN = 13

' Constants for Oracle server error numbers.
Const ORA_ERROR_NO_ERROR = 0
Const ORA_ERROR_UNIQUE_CONSTRAINT = 1
Const ORA_ERROR_CHECK_CONSTRAINT = 2290
Const ORA_ERROR_FK_NO_PARENT = 2291
Const ORA_ERROR_FK_CHILD_FOUND = 2292
Const ORA_ERROR_APP_ERROR_LOW = 20000
Const ORA_ERROR_APP_ERROR_HIGH = 20999
Const ORA_ERROR_RECURSIVE_SQL = 604
Const ORA_ERROR_ROW_LOCKED = 54
Const ORA_ERROR_TABLE_NOEXIST = 942

' Constants for SQLServer error numbers
Const SSV_ERROR_TABLE_NOEXIST = 239
Const SSV_ERROR_CHECK_CONSTRAINT = 547
Const SSV_ERROR_UNIQUE_CONSTRAINT = 2627

' Constants for the Domain Validation AOF.
'
' String constant for Domain parameter
Global Const gDOMAIN_PARAM = "Domain"
Global Const gCODE_PARAM = "Code"
' Querydef and recordset for Domain
Private qdfDV        As QueryDef
Private dysRefCodes  As Recordset
' 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


' Constants for the Code Controls AOF.
'
' Form level querydef for code controls sequence (ccseq) i.e ldnextidcc
Private qdfSeqId     As QueryDef
' Form level querydef for sequence i.e ldnextidseq
Private qdfseq       As QueryDef


' Constants for the Seq In Parent AOF.
'
' querydef for resequence/deleterow
Global gqdfReSeq     As QueryDef
' querydef for resequence up/down
Global gqdfSwap     As QueryDef
' Form level dynaset for resequence up/down
Private mdysSwap As Recordset
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

  ' LD.BAS: pctlStatusUser.Caption = "  User:  " & gstrUserName & "@" & gstrDatabaseName
  
  On Error GoTo ldStatusUserLogonErr
  
  ' If frmldLogon.ldCreateSession has set up user/database info,
  '   then use that.  Otherwise, take info from database object
  If (gstrUserName <> "") Then
    pctlStatusUser.Caption = "  User:  " & gstrUserName & _
                                     "@" & gstrDatabaseName
  Else
    pctlStatusUser.Caption = "  Database: " & gDatabase.Name
    pctlStatusUser.Caption = pctlStatusUser.Caption & " Version: " & gDatabase.Version
  End If
  
  Exit Sub
  
ldStatusUserLogonErr:
  ' ignore error referencing gDatabase.version if object does not support
  If Err = 3251 Then
    Resume Next
  Else
    Error Err
  End If
End Sub

Function ldDeleteRow(ByVal pstrTableName As String, ByVal pstrWhere As String, ByVal pstrColumn As String, _
                    ByVal pstrParam As String, ByVal pstrParamVals As String, pColErrors As Variant, pstrSql As String) 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
' pstrParam      IN  The parameters name to use in the sql statement to create querydef object
' pstrParamVals  IN  The parameters values associated to parameters names to assign it to the querydef object
' pColErrors     OUT The Errors Collection returned from the server
' pstrSql        OUT SQL statement issued to the server
'
' RETURNS
' True  - The row was deleted
' False - The row was not deleted
'
'
  Dim strSql As String
  Dim dysDelete As Recordset
  Dim qdfDelete As QueryDef
  
  On Error GoTo ldDeleteRow_Err
  
  ' Assume that the row could not be deleted
  ldDeleteRow = False
  
  ' Initialise the output parameters
  pstrSql = ""
  Set pColErrors = Nothing
  
  strSql = pstrParam & gSQL_KEYWD_SELECT & pstrColumn & gSQL_KEYWD_FROM & pstrTableName & gSQL_KEYWD_WHERE & pstrWhere
  
  ' Create querydef from the constructed SQL
  Set qdfDelete = LD.gDatabase.CreateQueryDef("", strSql)
  ' Extract bindvalues associated with bind names
  Call ldSetBindParametersVals(pstrParamVals, qdfDelete)
  
  ' Create the dynaset based on querydef
  Set dysDelete = qdfDelete.OpenRecordset(dbOpenDynaset)
  
  ' NB. MoveLast required for 424472
  dysDelete.MoveLast
  dysDelete.MoveFirst
  
  ' 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.Delete
  
  dysDelete.Close
  
  ' The row was deleted
  ldDeleteRow = True

  Exit Function

ldDeleteRow_Err:
  If ldIsServerError(Errors) Then
    If Not ldMsgServerError("", "", strSql, Errors) Then
      Set pColErrors = Errors
      pstrSql = strSql
    End If
  Else
    Call lgMsgVBError("LDDAO.BAS", "ldDeleteRow", Err)
  End If
  Exit Function

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 strSql As String
Dim i, intArraySize As Integer
  
  On Error GoTo ldDVPopulateDom_Err
  If qdfDV Is Nothing Then
    strSql = gSQL_KEYWD_PARAMETERS
    strSql = strSql & "[" & gDOMAIN_PARAM & "] " & "TEXT; "
    strSql = strSql & gSQL_KEYWD_SELECT & "RV_LOW_VALUE, RV_MEANING, RV_ABBREVIATION" & gSQL_KEYWD_FROM & pstrTableName & gSQL_KEYWD_WHERE & "RV_DOMAIN = " & "[" & gDOMAIN_PARAM & "]"
    Set qdfDV = gDatabase.CreateQueryDef("", strSql)
    qdfDV.Parameters(gDOMAIN_PARAM) = pstrDomain
    Set dysRefCodes = qdfDV.OpenRecordset(dbOpenSnapshot)
  Else
    qdfDV.Parameters(gDOMAIN_PARAM) = pstrDomain
    dysRefCodes.Requery qdfDV
  End If
  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.MoveLast
    intArraySize = dysRefCodes.RecordCount
    If pintAddUnknown <> gNO_UNKNOWN Then
       intArraySize = intArraySize + 1
    End If
    ReDim paDomain(intArraySize - 1) As lgDomain
    dysRefCodes.MoveFirst
    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
      paDomain(i).Meaning = strMeanField
      i = i + 1
    End If

    dysRefCodes.MoveNext
  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 ldIsServerError(Errors) Then
    Call ldMsgServerError("LDDAO.BAS", "ldDVPopulateDom", strSql, Errors)
    Exit Sub
  Else
    Call lgMsgVBError("LDDAO.BAS", "ldDVPopulateDom", Err)
  End If

End Sub


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 strSql       As String
Dim dysSeqId     As Recordset
Dim intSeqNum    As Integer
  
  ' Assume that the function was unable to lock the row
  'intRowlocked = False

  On Error GoTo ldNextIdCC_Err

  ' If tableName has not been supplied return 0 and exit function
  If pstrTableName = "" Then
    ldNextIdCC = 0
    Call lgMsg(glmdNULL_TABLENAME, gMG_SEV_ERROR)
    Exit Function
  End If
  
  ' If a tableName has been supplied and qdfSeqId is Nothing then
  ' construct the SQL statement
  
  If qdfSeqId Is Nothing Then
    strSql = gSQL_KEYWD_PARAMETERS
    strSql = strSql & "[" & gDOMAIN_PARAM & "] " & "TEXT; "
    strLHS = "Select CC_NEXT_VALUE from " & pstrTableName
    If pstrDomain <> "" Then
      strWhere = " where CC_DOMAIN = " & "[" & gDOMAIN_PARAM & "]"
    End If
    strSql = strSql & strLHS & strWhere
    Set qdfSeqId = LD.gDatabase.CreateQueryDef("", strSql)
  End If
  
  qdfSeqId.Parameters(gDOMAIN_PARAM) = pstrDomain
  Set dysSeqId = qdfSeqId.OpenRecordset(dbOpenDynaset)
  
  ' NB. MoveLast required for 424472
  dysSeqId.MoveLast
  dysSeqId.MoveFirst

  ' 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.Edit
    dysSeqId![CC_NEXT_VALUE].Value = intSeqNum + 1
    dysSeqId.Update
  End If
  
  Exit Function

ldNextIdCC_Err:
  If ldIsServerError(Errors) Then
    Call ldMsgServerError("LDDAO.BAS", "ldNextIdCC", strSql, Errors, pstrTableName)
  Else
    Call lgMsgVBError("LDDAO.BAS", "ldNextIdCC", Err)
  End If
  
  Exit Function

End Function

Function ldNextIdSeq(ByVal pstrSeqName As String) As Long
'
' DESCRIPTION
' This function returns the current sequence number from the sequence specified.
' It is only applicable for Oracle and will only be called if sequence definition
' in repository is marked as oracle sequence.
'
' 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 Recordset

  ' 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"
  
  ' SQL PassThrough is used as it bypass the Microsoft Jet database engine query processor
  ' and route foreign-dialect SQL statements to an external database server like Oracle.
  Set dysSeq = LD.gDatabase.OpenRecordset(strSql, dbOpenSnapshot, dbSQLPassThrough)
  
  ldNextIdSeq = dysSeq![NEXTVAL]

  Exit Function

ldNextIdSeq_Err:
  If ldIsServerError(Errors) Then
    Call ldMsgServerError("LDDAO.BAS", "ldNextIdSeq", strSql, Errors)
  Else
    Call lgMsgVBError("LDDAO.BAS", "ldNextIdSeq", Err)
  End If
  Exit Function

End Function


Function ldSPResequence(ByVal pstrColumn As String, pctlList As Control, pobjReSeqQdf As Object, _
                        pvarArray() As Variant, pColErrors As Variant, pstrSql As String) 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
' 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
' pobjReSeqQdf   IN  The Query definition object to create dynaset type recordset
' pvarArray      IN/OUT The sequence array to update
' pColErrors     OUT The Errors Collection returned from the server
' pstrSql        OUT SQL statement issued to the server
'
' RETURNS
' True  - The row was updated
' False - The row was not updated
'
'
Dim strSql As String
Dim dysUpdate As Recordset
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
  pstrSql = ""
  Set pColErrors = Nothing
 
  ' Initialise the row not selected count
  intNotSel = 0

  Set dysUpdate = pobjReSeqQdf.OpenRecordset(dbOpenDynaset)

  ' 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.Edit
        dysUpdate(pstrColumn).Value = intNotSel
        dysUpdate.Update

      End If
      ' Move to the next row in the dynaset
      ' for each row that is not selected.
      dysUpdate.MoveNext

    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:
  If ldIsServerError(Errors) Then
    If Not ldMsgServerError("", "", strSql, Errors) Then
      Set pColErrors = Errors
      pstrSql = strSql
    End If
  Else
    Call lgMsgVBError("LDDAO.BAS", "ldSPResequence", Err)
  End If
  Exit Function

End Function

Function ldSPSwap(ByVal pstrColumn As String, pobjSwapQdf As Object, pColErrors As Variant, _
pstrSql As String) 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
' pstrColumn     IN  The column to use in the select statement, so to allow the dynaset to be updateable
' pobjSwapQdf    IN  The Query definition object to create dynaset type recordset
' pColErrors     OUT The Errors Collection returned from the server
' pstrSql        OUT SQL statement issued to 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
  pstrSql = ""
  Set pColErrors = Nothing
  
  ' create dynaset type recordset if not already created otherwise refresh
  ' by using requery method. Note requery is not allowed within transaction
    
  If mdysSwap Is Nothing Then
    Set mdysSwap = pobjSwapQdf.OpenRecordset(dbOpenDynaset)
  Else
    mdysSwap.Requery pobjSwapQdf
  End If
  
  ' Commence the database transaction
  If ldTransactionBegin() Then

    bTransCancel = True

    ' Update the database sequence
    Dim intSeq1 As Integer
    Dim intSeq2 As Integer

    intSeq1 = mdysSwap(pstrColumn).Value
    mdysSwap.MoveNext
  
    ' 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.Edit
      mdysSwap(pstrColumn).Value = intSeq1
      mdysSwap.Update
      mdysSwap.MovePrevious
    
      mdysSwap.Edit
      mdysSwap(pstrColumn).Value = intSeq2
      mdysSwap.Update
      
      ' 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:
  If ldIsServerError(Errors) Then
    If Not ldMsgServerError("", "", strSql, Errors) Then
      Set pColErrors = Errors
      pstrSql = strSql
    End If
  Else
    Call lgMsgVBError("LDDAO.BAS", "ldSPSwap", Err)
  End If
  
  Resume ldSPSwap_Exit

End Function

Function ldSrvErrConstraint(pColErrors As Variant) As String
'
' DESCRIPTION
' This function finds the constraint name embedded in the error message text.

' PARAMETER
' pColErrors IN  The errors collection
'
' RETURNS
' String       - That contains the constraint name embedded in the message
' Empty String - If the message did not contain a constraint name

' CONSTANTS
' Constants used to find the constraint name within an Oracle server error
' The format of an Oracle constraint 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 ORA_SE_MSG_PREFIX = "ORA-"    ' The product prefix
Const ORA_SE_MSG_CODE_SEP = ":"     ' Prefix and message separator
Const ORA_SE_CONSTR_START = "("     ' Start character of the constraint name
Const ORA_SE_CONSTR_END = ")"       ' End character of the constraint name
Const ORA_SE_CONSTR_SEP = "."       ' Schema and constraint name separator

' Constants used to find the constraint name within an SQLServer error
' The format of a SQLServer constraint message is as follows:
'        xxxxx 'zzzzz'y xxxxx
'        xxxxx is a character string
'        zzzzz is the constraint name in a constraint violation
'        y     could be ":" or "." or space
Const SSV_SE_CONSTR_QUOTE = "'"       ' sql server constraint name separator

Dim intStartPos As Integer
Dim intStopPos  As Integer
 
  ldSrvErrConstraint = ""
  
  ' Check for Oracle style format
  ' =============================
  ' Find the position of the first opening bracket
  intStartPos = InStr(pColErrors(0).Description, ORA_SE_CONSTR_START)
  ' If the start of the constraint name was found, find the separator
  If (intStartPos <> 0) Then
    ' Find the position of first end bracket
    intStopPos = InStr(intStartPos, pColErrors(0).Description, ORA_SE_CONSTR_END)
    If (intStopPos <> 0) Then
      intStartPos = InStr(intStartPos, pColErrors(0).Description, ORA_SE_CONSTR_SEP)
      ' odbc can put se_constr_sep i.e '.' at the end of line
      If (intStartPos <> 0) And (intStartPos < intStopPos) Then
        ' There was a separator, so strip the constraint name
        ldSrvErrConstraint = Mid(pColErrors(0).Description, intStartPos + 1, InStr(intStartPos, pColErrors(0).Description, ORA_SE_CONSTR_END) - intStartPos - 1)
      End If
    End If
  End If
 
  ' Check for SQLServer style format
  ' ================================
  intStartPos = InStr(pColErrors(0).Description, SSV_SE_CONSTR_QUOTE)
  If intStartPos <> 0 Then
    intStopPos = InStr(intStartPos + 1, pColErrors(0).Description, SSV_SE_CONSTR_QUOTE)
    If intStopPos <> 0 Then
      ldSrvErrConstraint = Mid(pColErrors(0).Description, intStartPos + 1, intStopPos - intStartPos - 1)
    End If
  End If

End Function

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
  
  gWorkspace.BeginTrans
  ' The transaction was started
  ldTransactionBegin = True

  Exit Function

ldTransactionBegin_Err:
  Call lgMsgVBError("LDDAO.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
  gWorkspace.CommitTrans
  ' The transaction was committed
  ldTransactionCommit = True
  Exit Function

ldTransactionCommit_Err:
  If ldIsServerError(Errors) Then
    Call ldMsgServerError("LDDAO.BAS", "ldTransactionCommit", "", Errors)
  Else
    Call lgMsgVBError("LDDAO.BAS", "ldTransactionCommit", Err)
  End If
  
  Exit Function

End Function

Sub ldTransactionRollback()
'
' DESCRIPTION
' This function rolls back the current transaction

  On Error GoTo ldTransactionRollBack_Err
  gWorkspace.Rollback
  Exit Sub

ldTransactionRollBack_Err:
  Call lgMsgVBError("LDDAO.BAS", "ldTransactionRollBack", Err)
  Call lgMsg(glmdRESET_TRANS, gMG_SEV_WARN)
  
  Exit Sub

End Sub


Function ldErrorClass(colError As Variant) As Integer
'
' DESCRIPTION
' This function returns the class of server error that has occured
' It is only applicable to Oracle and Sql Server
'
' PARAMETERS
' colError  IN  Error Collection
'
' RETURNS
'   Error class

  ldErrorClass = LD_ERROR_IS_NO_ERROR

  ' Check for Oracle Error Numbers
  ' ==============================
  Select Case colError(0).Number
    ' oracle error codes for lock, delete, changed etc
    Case ORA_ERROR_ROW_LOCKED
      ldErrorClass = LD_ERROR_IS_ROW_LOCKED
    Case ORA_ERROR_TABLE_NOEXIST
      ldErrorClass = LD_ERROR_IS_TABLE_NOEXIST
    Case ORA_ERROR_NO_ERROR
      ldErrorClass = LD_ERROR_IS_NO_ERROR
    Case ORA_ERROR_UNIQUE_CONSTRAINT
      ldErrorClass = LD_ERROR_IS_UNIQUE_CONSTRAINT
    Case ORA_ERROR_CHECK_CONSTRAINT
      ldErrorClass = LD_ERROR_IS_CHECK_CONSTRAINT
    Case ORA_ERROR_FK_NO_PARENT
      ldErrorClass = LD_ERROR_IS_FK_NO_PARENT
    Case ORA_ERROR_FK_CHILD_FOUND
      ldErrorClass = LD_ERROR_IS_FK_CHILD_FOUND
    Case Else
      ldErrorClass = LD_ERROR_IS_UNKNOWN
  End Select
  
  Exit Function   'TEST ONLY
  
  
  ' Check for SQLServer Error Numbers
  ' =================================
  Select Case colError(0).Number
    ' sql server error codes for lock, delete, changed etc
    Case SSV_ERROR_TABLE_NOEXIST
      ldErrorClass = LD_ERROR_IS_TABLE_NOEXIST
    ' sql server errors for constraint violation
    Case SSV_ERROR_UNIQUE_CONSTRAINT
      ldErrorClass = LD_ERROR_IS_UNIQUE_CONSTRAINT
    Case SSV_ERROR_CHECK_CONSTRAINT
      ldErrorClass = LD_ERROR_IS_CHECK_CONSTRAINT
    Case Else
      ldErrorClass = LD_ERROR_IS_UNKNOWN
  End Select

  Exit Function

End Function

Public Function ldIsServerError(colError As Variant) As Boolean
'
' DESCRIPTION
' This function checks whether the object svrError is an odbc source
' If srvError source contains odbc string then true is returned,
' otherwise false is returned.
'
' PARAMETERS
' colError    IN  The error collection object to check for error source
'
' RETURNS
' True  - If the user has entered a value
' False - If the given control is null
 
 'assume it not a server error
 ldIsServerError = False
 
 ' To determine if colError collection contains error object, use colError.count.
 ' To determine if the error information in the colError collection is valid, compare the
 ' Number property of the last element of the colError collection(colError(colError.Count-1))
 ' with the Visual Basic Err value. (Note: See help under topic ERROR OBJECT)
 
 If colError.Count > 0 Then
   If colError(colError.Count - 1).Number = Err.Number Then
     If InStr(colError(0).Source, "ODBC") Or InStr(colError(0).Source, "DAO") Then
       ldIsServerError = True
     End If
   End If
 End If

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 = "Jet/DAO version " & DBEngine.Version

  Exit Function

ldGetDataAccessInfoErr:
  ldGetDataAccessInfo = ""
  Exit Function
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 = "Database: " & gDatabase.Name & vbCrLf & _
    IIf(gDatabase.Connect = "", "", gDatabase.Connect & vbCrLf) & _
    "Version: " & gDatabase.Version
  
  Exit Function

ldGetUserLogonInfoErr:
  ldGetUserLogonInfo = ""
  
  Exit Function

End Function

Public Function ldQDBuildLiteral(pvarValue As Variant, ByVal pstrDtype As String) As Variant
'
' DESCRIPTION
' This function validates and 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
    If pvarValue = "True" Then
      ldQDBuildLiteral = -1
    ElseIf pvarValue = "False" Then
      ldQDBuildLiteral = 0
    Else
      ldQDBuildLiteral = "'" & pvarValue & "'"
    End If
  ElseIf pstrDtype = "D" Then
    ' Convert the date to standard format
    ldQDBuildLiteral = "#" & Format$(pvarValue, "dd-mmm-yyyy") & "#"
  Else
    ldQDBuildLiteral = pvarValue
  End If
  
End Function

Public Sub ldSetBindParametersVals(ByVal pstrParamVals As String, pobjQueryDef As Object)
'
' DESCRIPTION
' pstrParamVals Format is "[bindName1]=BindVal1;[BindName2]=BindVal2;" etc
' This routine extracts the bind parameter names
' and bind values, which are then assigned
' to the query definition pObjQuerydef
'
'
' PARAMETERS
' pstrParamVals           IN Bind values (if any).
' pObjQuerydef            IN Querydef Object

  If pstrParamVals <> "" Then
    Dim intParamStart  As Integer
    Dim intParamStop   As Integer
    Dim strParamName   As String
    
    intParamStart = 1
    Do
      ' extract parameter name
      intParamStart = InStr(intParamStart, pstrParamVals, "[")
      If intParamStart <> 0 Then
        intParamStop = InStr(intParamStart, pstrParamVals, ";")
        If (intParamStop <> 0) And (intParamStop > intParamStart) Then
          strParamName = Mid(pstrParamVals, intParamStart, intParamStop - intParamStart)
          intParamStart = InStr(1, strParamName, "]")
          If Len(strParamName) - 1 <> intParamStart Then
            ' parameter values found
            pobjQueryDef.Parameters(Mid(strParamName, 2, intParamStart - 2)) = _
            Mid(strParamName, intParamStart + 2, Len(strParamName))
          Else
            ' parameter value is not found i.e empty so set it to null
            pobjQueryDef.Parameters(Mid(strParamName, 2, intParamStart - 2)) = Null
          End If
          intParamStart = intParamStop
        End If
      End If
    Loop Until intParamStart = 0
  End If

End Sub

Function ldMsgServerError(ByVal pstrModule As String, ByVal pstrLocation As String, ByVal pstrSql As String, _
                          colError As Variant, Optional ByVal pstrTableName As Variant) As Boolean
'
' DESCRIPTION
' This routine is responsible for displaying detailed information about an server error, to the user
' Handle ODBC errors 'Row locked','Row Deleted', and 'Row Modified' etc with a user friendly message,
' other ODBC with ServerError dialog.
'
' PARAMETERS
' pstrModule    IN  The current module where the error occurred
' pstrLocation  IN  The location in the application code where the error occurred
' pstrSql       IN  The Sql statement in which the error occurred (if known)
' colError      IN  Error Collection
' pstrTableName IN  The Table name in the application code where the error occurred

  
  ldMsgServerError = False
  
  Select Case colError(colError.Count - 1).Number
    Case gVB_RECORD_LOCKED
      Call lgMsg(glmtROW_LOCKED, gMG_SEV_WARN)
    Case gVB_DATA_HAS_CHANGED
      Call lgMsg(glmtROW_MODIFIED, gMG_SEV_WARN)
    Case gVB_RECORD_DELETED
      Call lgMsg(glmtROW_DELETED, gMG_SEV_WARN)
    Case gVB_UPDATE_FAILED
      Call lgMsg(lgMsgSubst(glmdTABLE_NOT_SETUP, pstrTableName), gMG_SEV_FATAL)
    Case Else
      If pstrModule <> "" Then
        Call lgMsgServerError(pstrModule, pstrLocation, colError(0).Number, colError(0).Description, pstrSql)
      Else
        Exit Function
      End If
  End Select
  
  ldMsgServerError = True
  Exit Function

End Function
'  
' ----------------------------------------------------------------------------
' $$Header_is_done
'  End of file $RCSfile: lddao.bas $
' ----------------------------------------------------------------------------