Ali•MESHKOT•com

Sample Work

Sample Visual Basic for Applications (VBA) Code for MS Access

The following code demonstrates some programming techniques and object naming, which are meaningful and in accordance with a predefined naming convention.  Another sample work page has more details about the project.

Table of Contents

Public Sub Test1()
Public Sub Import()
Public Sub TextToSegmentTables()
Private Function CheckFilename()
Private Function ReplaceData()
Private Function CreateITxtTable()
Private Sub ImportToTextTable()
Private Function ArchiveBusObjSegTables 
Public Function TableExists
Public Sub LogError()
Public Sub TransferData()
Private Function TransferManualData
Public Sub AuditBusObj()
Private Function AuditSegment(bytSegmentIndex As Byte)
Public Function ReadHDREND(ReadType As Byte) 
Public Function SetCreateDate4AuditForm() 
Private Function BuildAuditSQLs 
Public Function AuditForm 
Public Function AuditDelRecMan 
Public Sub StopIllChar(KeyAscii)
Public Function sCreateUser 
Public Function RestoreChar 
Public Sub SetBOIRD()
Public Sub ShowMessage(strFormName As String, MsgID As Integer)
Private Function CheckHEADEND() 
Private Function BusObjSegmentToCurTable() 
Private Function BuildSegCurInsertSQL
Public Function SetUserInfo() 

' Module:    modImport

' By:       Dr M. A. Meshkot July 1999  Ref 13780421
'           Migration of databases from legacy mainframe systems to
'           Systems Applications and Products (SAP) software,
'           using MS Access as an intermediary
'
Option Compare Database
Option Explicit
Const conMaxSegmentCount = 15
Const conMaxSegFieldCount = 60
Const conMaxReplaceCharCount = 20
Const conForImportAudit = 10
Const conForFormAudit = 20
'   Give names to message numbers for clarity
Const MsgBadFilename = 101
Const MsgNotReplacingData = 102
Const MsgBadHDREND = 103
Const MsgCreateTextTableFailed = 104
Const MsgImportedTextFile = 105
Const MsgCreatedCurTables = 106
Const MsgNoCurTable = 108
Const MsgNoPrvTable = 109
Const MsgNoHDRENDRecord = 110
Const MsgOneHDRENDRecord = 111
Const MsgCkechHDRENDProgress = 113
Const MsgCkechHDRENDProblem = 114
Const MsgImportToTextTableProgress = 115
Const conMsgArchivingCURPRV = 116
Const conMsgFailedImport = 117
Const conMsgSegmentProcessing = 118
Const conMsgSegToCurTableError = 119
Const conMsgWaitImporting = 120
Const conMsgExportingToBackup = 120
Const conMsgFailedImportBadName = 121
Const conMsgNoUserInfo = 122

        Public Type AuditRecord '  SQLs for the audit trail
            SQLAdd As String
            SQLDel As String
            SQLChg(0 To 60) As String   ' made zero-based to match the field index
        End Type


        Public Type SegmentBOIRD
            fldID As String
            fldSortOrder As String
            fldNAME As String
            fldStartPosition As Integer
            fldLength As Integer
            fldDescription As String
            fldManElec As String
            fldSetTo As String
            fldKey As Boolean
            fldManUpdateCrit As Boolean
        End Type

    Public Type BusinessObjectSegment
        SegmentID As String
        FieldCount As Byte
        SQLSelectIRD As String
'        SQLSelectSegmentOfTxtCur As String
'        SQLAppendSegmentToCurTable As String
        IRD(1 To conMaxSegFieldCount) As SegmentBOIRD
        AuditSQLAssigned As Boolean
        BOIRDAssigned As Boolean
        Audit As AuditRecord
    End Type

    Public Type BusinessObjectHRDEND
        HDR As String   ' Full header
        END As String   ' Full End record
        ImportDate As Date
        ImportEnd As Date
        HDRTag As String
        CoreID As String
        HDRLegApp As String
        HDRSiteCode As String
        CreateDate As String
        CreateTime As String
        EndID As String
        EndSP As String
        EndSite As String
        RecordCount As Long     ' Before importing into tbl*TxtCur
    End Type

Public Type BusinessObject
        Name As String
        ID As String
        Filename As String
        FilePath As String
        FileNamePath As String
        ArchivePath As String
        WhollyManual As Boolean
        SegmentCount As Integer
        IFL As Long ' Import File Length in characters
        ReadPos As Long     ' Import file Character read position
        HaltProcessing As Boolean
        LinesImported As Long   ' Number of records in Tbl*TxtCur
        Segment(1 To conMaxSegmentCount) As BusinessObjectSegment
        PrevImports As Integer
        HDRENDAssigned As Boolean
        SQLSelectHDREND As String
        HDREND(0 To 2) As BusinessObjectHRDEND  ' (0) and (1) are the same, _
                                                    except that (0) is set during CheckHDREND and (1) is read from tblHDREND _
                                                    This becomes significant with wholly manual business objects.
End Type
Public Type CurrentUserInfo '199906301048
    Firstname As String
    Lastname As String
    MudID As String
End Type


Public BusObj As BusinessObject
Public User As CurrentUserInfo

Public PubStrBusObjName As String
Public pubstrBusObjImpID As String
Public PubStrBusObjImpFilename As String
Public PubStrBusObjImpFilePath As String
Public PubStrBusObjImpFileNamePath As String
Public pubstrBusObjArchivePath As String
Public pubbolBusObjWhollyManual As Boolean
Public pubstrSegmentID As String

Private strImpRecord As String
Private strSelectIRD As String
Private strSQLAudAddRec As String
Private strSQLAudDelRec As String
Private strSQLAudChgRec As String
Private strResult As String
Private strCurCreateDate As String
Private strPrvCreateDate As String
Private strHDRCur As String
Private strHDRPrv As String
Private strSegmentType(1 To conMaxSegmentCount) As String
Private strInsertSegmentSQL(1 To conMaxSegmentCount) As String
Private dteCurReadDate As Date
Private dtePrvReadDate As Date
Private intMsgReply As Integer
Private bytBOIRDTypeCount As Byte
Private bytRecordCountIRD As Byte
Private bolResult As Boolean
Private varMsgResponse
Private rstBOIRD As Recordset
Private recIRD As recBOIRD
Private Type recBOIRD
    fldID(1 To conMaxSegFieldCount) As String
    fldSortOrder(1 To conMaxSegFieldCount) As String
    fldNAME(1 To conMaxSegFieldCount) As String
    fldStartPosition(1 To conMaxSegFieldCount) As Integer
    fldLength(1 To conMaxSegFieldCount) As Byte  ' All the field lengths are currently Byte
    fldDescription(1 To conMaxSegFieldCount) As String
    fldManElec(1 To conMaxSegFieldCount) As String
    fldSetTo(1 To conMaxSegFieldCount) As String
    fldKey(1 To conMaxSegFieldCount) As Boolean
    fldManUpdateCrit(1 To conMaxSegFieldCount) As Boolean
End Type



Public Sub Test1()

'To test TransferText method of importing
    Dim mysub
    Dim bytCount As Byte
    With BusObj
        .FilePath = "C:\SMAM\SP1Dev199906221450\Input\"
        .ArchivePath = "C:\SMAM\SP1Dev199906221450\Output\"
        .Filename = "PS40BMMShort.txt"
        .ID = "40BDAPS01"
        .FileNamePath = .FilePath + .Filename
    End With
'   Testing Search and Replace Data
'    ReplaceIllCharInTxtCur
'    Debug.Print Now(), strResult
'    If ReplaceData = False Then
'        Call ShowMessage("frmMessage", MsgNotReplacingData)
'    End If
End Sub



Public Sub Import()

'   Import legacy extract to tblI*TxtCur
Dim bolResult As Boolean
Dim strMessage As String
Dim strResult As String
    strResult = CheckFilename()
    If strResult <> "OK" Then
        Call ShowMessage("frmMessage", conMsgFailedImport)
        Forms!frmMessage!lblMsg2.Caption = strResult
        DoCmd.RepaintObject acForm, "frmMessage"
        GoTo SubFail
    End If
    
    If ReplaceData = False Then
        Call ShowMessage("frmMessage", MsgNotReplacingData)
        GoTo SubFail
    End If
    
    strResult = CheckHEADEND()
    If strResult <> "OK" Then GoTo SubFail
    
    If CreateITxtTable <> True Then GoTo SubFail
    
    ImportToTextTable
        Call ShowMessage("frmMessage", MsgImportedTextFile)
SubFail:
'       No Import, Reason already displayed.
NormalExit:
End Sub

Public Sub TextToSegmentTables()
'   Transfer data from tblI*TxtCur to tblI*S0*Cur
'   Version 2.0 of SP1Ctrl      199906251320
'   Modified: 199906251608, 199907051418
    If ArchiveBusObjSegTables = False Then
        GoTo SubFail
    End If
    
    bolResult = BusObjSegmentToCurTable()
    If bolResult <> True Then GoTo SubFail
    GoTo NormalExit
SubFail:
'       No Import, Reason already displayed.
NormalExit:
End Sub


Private Function CheckFilename() _

                                    As String
'   Checks BusObj file name and path
'   Version 2.0 of SP1Ctrl      199906231556
Const conNameMinLength = 20
    CheckFilename = "ERROR"
    With BusObj
        If .WhollyManual Then	' Wholly Manual means all data is entered by the user
            CheckFilename = "There is no legacy extract for the selected business object.  "
            GoTo ExitWithError
        End If
        .FileNamePath = Trim(.FilePath) _
                & Trim(.Filename)
        Select Case Len(.FileNamePath)
            Case Is = 0
                CheckFilename = "No Business Object has been selected, " _
                & "Please select one first."
                GoTo ExitWithError
            Case Is < conNameMinLength
                CheckFilename = "There seem to be too few characters in the " _
                & "path/filename combination"
                GoTo ExitWithError
        End Select
        CheckFilename = "OK"
    End With
    Exit Function
ExitWithError:
    Debug.Print Now(), "Trim(BusObj.FilePath ) = "; Trim(BusObj.FilePath)
    Debug.Print Now(), "Trim(BusObj.Filename) = "; Trim(BusObj.Filename)
    Debug.Print Now(), "BusObj.FileNamePath = "; BusObj.FileNamePath
    Debug.Print Now(), "CheckFilename = "; CheckFilename
End Function


Private Function ReplaceData() _

                                As Boolean
'   Checks to see if there is existing data and asks the user for confirmation before replacing it.
Dim strImpTxtTableNameCur As String
Dim strImpTxtTableNamePrv As String
Dim strMessage As String
    ReplaceData = False
    strMessage = BusObj.ID & "  " & BusObj.Name & vbCrLf _
                & "There is already a legacy download extract in this database " _
                & "for the selected Business Object.  If you select YES to replace it, " _
                & "manual fields of newly imported records will be overwritten by the existing ones.  " _
                & "In that case you may loose the information entered manually on legacy systems." _
                & vbCrLf & vbCrLf & "Would you like to Import the data again?"
    strImpTxtTableNameCur = "tblI" & BusObj.ID & "TxtCur"
    strImpTxtTableNamePrv = "tblI" & BusObj.ID & "TxtPrv"
    varMsgResponse = vbNo
    If TableExists(strImpTxtTableNameCur) Then
        varMsgResponse = MsgBox(strMessage, vbApplicationModal + vbYesNoCancel, "Replace Existing Data?")
    Else
        varMsgResponse = vbYes
    End If
    
    If varMsgResponse = vbYes Then GoTo lblReplace
lblAbort:
    GoTo lblEndFunction
lblReplace:
    If TableExists(strImpTxtTableNamePrv) _
                And TableExists(strImpTxtTableNameCur) Then
        CurrentDb().TableDefs.Delete (strImpTxtTableNamePrv)
        DoCmd.Rename strImpTxtTableNamePrv, acTable, strImpTxtTableNameCur
    ElseIf TableExists(strImpTxtTableNameCur) Then
        DoCmd.Rename strImpTxtTableNamePrv, acTable, strImpTxtTableNameCur
    End If
    ReplaceData = True
lblEndFunction:
End Function


Private Function CreateITxtTable() _

                                    As Boolean
'   Create a 1-field table where each row is to contain one line of the imported text file.
'   Version 2.0 of SP1Ctrl      199906231328
On Error GoTo ExitError
Dim strImpTxtTableName As String
Dim bytCount As Byte
Dim tdfImpTxtTable As TableDef
Dim fldImpTxtField As Field
    strImpTxtTableName = "tblI" & BusObj.ID & "TxtCur"
    Set tdfImpTxtTable = CurrentDb().CreateTableDef(strImpTxtTableName)
    With tdfImpTxtTable
        Set fldImpTxtField = .CreateField("fld" & BusObj.ID & "TxtCur", dbMemo)
        .Fields.Append fldImpTxtField
    End With
    With CurrentDb().TableDefs
        .Append tdfImpTxtTable
        .Refresh
    End With
    CreateITxtTable = True
    Exit Function
ExitError:
    CreateITxtTable = False
    On Error Resume Next
    Call ShowMessage("frmMessage", MsgCreateTextTableFailed)
End Function


Private Sub ImportToTextTable()

Dim strInChar As String * 1
Dim strTableName As String
Dim strSQL As String
    With BusObj
        .HaltProcessing = False
        .IFL = 0
        .ReadPos = 0
    End With
    strTableName = "tblI" & BusObj.ID & "TxtCur"
    Call ShowMessage("frmMessage", conMsgWaitImporting)
'   Use the TransferText method which is faster, but instead needs the controller to create
'   an import specification for any new business object.  The spec name is the same as the bus. obj ID.
    DoCmd.TransferText acImportFixed, BusObj.ID, strTableName, BusObj.FileNamePath, 0
    DoCmd.Close acForm, "frmMessage"
End Sub





Private Function ArchiveBusObjSegTables _

                                () As Boolean
Dim strImpTableNameCur As String
Dim strImpTableNamePrv As String
Dim bytCount As Byte
Dim tdfImpTable As TableDef
Dim fldImpField As Field
Dim strMessage As String
Dim bytSegmentCounter As Byte
'    On Error GoTo ExitError
    ArchiveBusObjSegTables = False
    For bytSegmentCounter = 1 To BusObj.SegmentCount
        With BusObj.Segment(bytSegmentCounter)
            strImpTableNamePrv = "tblI" & BusObj.ID & .SegmentID & "Prv"
            strImpTableNameCur = "tblI" & BusObj.ID & .SegmentID & "Cur"
        End With
        Call ShowMessage("frmMessage", conMsgArchivingCURPRV)
        pubstrMsg2 = "Now archiving segment " & bytSegmentCounter & " of " & BusObj.ID
        Forms!frmMessage!lblMsg2.Caption = pubstrMsg2
        DoCmd.RepaintObject acForm, "frmMessage"
        If TableExists(strImpTableNamePrv) _
                    And TableExists(strImpTableNameCur) Then
'       Make a copy of the CUR & PRV table to file (some data will be archived at both stages).
            DoCmd.OutputTo acOutputTable, strImpTableNameCur, acFormatXLS, _
                        BusObj.ArchivePath & strImpTableNameCur & Format(Now(), "yyyymmddhhnnss") & ".xls", False
            DoCmd.OutputTo acOutputTable, strImpTableNamePrv, acFormatXLS, _
                        BusObj.ArchivePath & strImpTableNamePrv & Format(Now(), "yyyymmddhhnnss") & ".xls", False
            CurrentDb().TableDefs.Delete (strImpTableNamePrv)
            DoCmd.Rename strImpTableNamePrv, acTable, strImpTableNameCur
        ElseIf TableExists(strImpTableNameCur) Then
            DoCmd.OutputTo acOutputTable, strImpTableNameCur, acFormatXLS, _
                        BusObj.ArchivePath & strImpTableNameCur & Format(Now(), "yyyymmddhhnnss") & ".xls", False
            DoCmd.Rename strImpTableNamePrv, acTable, strImpTableNameCur
        End If
        DoCmd.Close acForm, "frmMessage"
        CurrentDb().TableDefs.Refresh
        
NextSegment:
    Next
    ArchiveBusObjSegTables = True
    Exit Function
ExitError:
    MsgBox Err & ": " & Err.Description
    On Error Resume Next
    
End Function


Public Function TableExists _

                                (TableName As String) As Boolean
Dim tdfTableDef As TableDef
    TableExists = False
    For Each tdfTableDef In CurrentDb().TableDefs
        If TableName = tdfTableDef.Name Then
            TableExists = True
            GoTo ExitFunction
        End If
    Next
ExitFunction:
End Function


Public Sub LogError()

Dim strErrSQL As String
    strErrSQL = "INSERT INTO tblErrLog VALUES ( " _
                    & "'" & Now() & "', " _
                    & "'" & CurrentUser & "', " _
                    & "'" & Err.Source & "', " _
                    & "'" & Err.Number & "', " _
                    & "'" & Err.Description & "' ); "
    CurrentDb().Execute strErrSQL, dbFailOnError
    Resume Next
End Sub


Public Sub TransferData()

'   Transfer manual data from tblI*PRV to tblI*Cur
'   Version 2.0 of SP1Ctrl      199907051440
Dim strTableNameCur As String
Dim strTableNamePrv As String
Dim bytSegmentCounter As Byte
Dim strTransferResult As String
Dim strMessage As String
    For bytSegmentCounter = 1 To BusObj.SegmentCount
        If Left$(BusObj.Segment(bytSegmentCounter).SegmentID, 1) <> "S" Then GoTo NextSegment
        strTableNameCur = "tblI" & BusObj.ID & BusObj.Segment(bytSegmentCounter).SegmentID & "Cur"
        strTableNamePrv = "tblI" & BusObj.ID & BusObj.Segment(bytSegmentCounter).SegmentID & "Prv"
        If TableExists(strTableNamePrv) Then
            strTransferResult = TransferManualData _
                (bytSegmentCounter, strTableNameCur, strTableNamePrv)
        End If
NextSegment:
    Next
    strMessage = "Transfered Manual data (if any) to newly imported tables"
    varMsgResponse = MsgBox(strMessage, vbApplicationModal + vbInformation + vbOKOnly, "Manual Data from Previous Import")
    
End Sub



Private Function TransferManualData _

    (bytSegmentIndex As Byte, strTableNameCur As String, strTableNamePrv As String) As String
'   Transfer Manual Field values from Prv tables to Cur tables based on the Manual Transfer Criteria
Dim strTableName As String
Dim strTransferSQL As String
Dim strSQLCur As String
Dim strSQLPrv As String
Dim strSQLElec As String
Dim strSQLUpdate As String
Dim strSQLEquateCurToPrv As String
Dim bytFieldCounter As Byte
Dim qdfTableCur As QueryDef
Dim qdfTablePrv As QueryDef
Dim rstUpdateCur As Recordset

    strSQLElec = ""
'   Create the calculated field part of the SQL statement
'       which concatenates all the electronic fields, which are part of the manual transfer criteria.
    With BusObj.Segment(bytSegmentIndex)
        For bytFieldCounter = 1 To .FieldCount
            If (.IRD(bytFieldCounter).fldManElec = "E") _
                    And (.IRD(bytFieldCounter).fldManUpdateCrit = True) Then
                strSQLElec = strSQLElec & " & fld" & .IRD(bytFieldCounter).fldNAME & " & "
            End If
        Next
    End With
'   Delete last &
    strSQLElec = Left$(strSQLElec, Len(strSQLElec) - 3)
'   Delete first &
    strSQLElec = Mid$(strSQLElec, 3)
'   Now build the SQL for the CURrent and PReVious tables of the present segment.
    strSQLCur = "SELECT * , " & strSQLElec & " AS strConcatElec " _
                & " FROM " & strTableNameCur & ";"
    strSQLPrv = "SELECT * , " & strSQLElec & " AS strConcatElec " _
                & " FROM " & strTableNamePrv & ";"
'   Build the part of the Update SQL statement to equate manual current to previous fields
    strSQLEquateCurToPrv = ""
    With BusObj.Segment(bytSegmentIndex)
        For bytFieldCounter = 1 To .FieldCount
            If .IRD(bytFieldCounter).fldManElec = "M" Then
            strSQLEquateCurToPrv = strSQLEquateCurToPrv & " , " _
                & "qryTempTableCur.fld" & .IRD(bytFieldCounter).fldNAME & " = " _
                & "qryTempTablePrv.fld" & .IRD(bytFieldCounter).fldNAME
            End If
        Next
    End With
'   An error occurs here if no Manual fields are indicated in the fldManElec of tblBOIRD
'   Hence avoid it:
    If Trim$(strSQLEquateCurToPrv) = "" Then
        TransferManualData = "There is no 'Manual Data' to transfer from the previous legacy download " _
                            & "for table " & vbCrLf & strTableNameCur
        intMsgReply = MsgBox(TransferManualData, vbInformation _
                        + vbApplicationModal + vbOKOnly, "No Manual Data Fields")
        Exit Function
    End If
'   Delete the first comma-space and add a semicolon
    strSQLEquateCurToPrv = Mid$(strSQLEquateCurToPrv, 3) & ";"
'   Build the UPDATE SQL
    strSQLUpdate = "UPDATE qryTempTableCur INNER JOIN qryTempTablePrv " _
                & " ON qryTempTableCur.strConcatElec = qryTempTablePrv.strConcatElec " _
                & "SET " & strSQLEquateCurToPrv
    
    Debug.Print Now(), "strSQLCur = "; strSQLCur
    Debug.Print Now(), "strSQLPrv = "; strSQLPrv
    Debug.Print Now(), "strSQLUpdate = "; strSQLUpdate
    
    
'   Create queries based on the SQLs.
'   When the name is provided, the query is automatically appended to the collection
    Set qdfTableCur = CurrentDb().CreateQueryDef("qryTempTableCur", strSQLCur)
    Set qdfTablePrv = CurrentDb().CreateQueryDef("qryTempTablePrv", strSQLPrv)
    CurrentDb().QueryDefs.Refresh
    CurrentDb().Execute strSQLUpdate, dbFailOnError
    With CurrentDb().QueryDefs
        .Delete "qryTempTableCur"
        .Delete "qryTempTableprv"
        .Refresh
    End With

    TransferManualData = "OK"
End Function


Public Sub AuditBusObj()

'   Produce audit records for each segment of the imported business object.
'   Audits a business object just after import using the controller import menu.
'   Version 2.0 of SP1Ctrl      199906280810
Dim bytCount As Byte
Dim bytSegmentCounter As Byte
Dim strTableNameCur As String
Dim strTableNamePrv As String
Dim strMessage As String
Dim strAuditSegmentResult As String
    If BusObj.WhollyManual Then Exit Sub
'   Check to see that there have been at least 2 legacy downloads for this business object,
'   and get the dates.
    If Not ReadHDREND(conForImportAudit) Then Exit Sub
    For bytSegmentCounter = 1 To BusObj.SegmentCount
        If Left$(BusObj.Segment(bytSegmentCounter).SegmentID, 1) <> "S" Then GoTo NextSegment
        
         strAuditSegmentResult = AuditSegment(bytSegmentCounter)
NextSegment:
    Next
    strMessage = "All Current and Previous tables (if any) of the selected business object have been audited"
    varMsgResponse = MsgBox(strMessage, vbApplicationModal + vbInformation + vbOKOnly, "Auditing Imported Records")
End Sub


Private Function AuditSegment(bytSegmentIndex As Byte) _

                                    As String
'   Audit a segment from imported Previous and Current tables
'   Version 2.0 of SP1Ctrl      199906280850
'   199906301050    Use the User variable when refering to User info.
Dim rstToAudit As Recordset
Dim fldToAudit As Field
Dim strCurTableName As String
Dim strPrvTableName As String
Dim strSQLInsertAuditAddSeg As String
Dim strSQLInsertAuditDelSeg As String
Dim strSQLInsertAuditChgSeg As String
Dim strConcatKey As String
Dim bytFieldCounter As Byte
Dim bytFieldCounter2 As Byte
        
'   Check to see that the CUR and PRV tables exist for the selected segment
    strCurTableName = "tblI" & BusObj.ID & BusObj.Segment(bytSegmentIndex).SegmentID & "Cur"
    strPrvTableName = "tblI" & BusObj.ID & BusObj.Segment(bytSegmentIndex).SegmentID & "Prv"
    If Not TableExists(strCurTableName) Then
        Call ShowMessage("frmMessage", MsgNoCurTable)
        GoTo ReturnFail
    End If
    
    If Not TableExists(strPrvTableName) Then
        Call ShowMessage("frmMessage", MsgNoPrvTable)
        GoTo ReturnFail
    End If

'   Build SQL statements to Select Records to Audit
    strResult = BuildAuditSQLs(bytSegmentIndex, strCurTableName, strPrvTableName)
'   Execute query for added records and write each record of the recordset to the audit table
    Set rstToAudit = CurrentDb().OpenRecordset _
                    (BusObj.Segment(bytSegmentIndex).Audit.SQLAdd, _
                    dbOpenSnapshot, dbDenyWrite, dbReadOnly)
    With rstToAudit
        While Not .EOF
'           Create the record's concatenated key which is required for the audit table
            strConcatKey = ""
            For bytFieldCounter = 0 To .Fields.Count - 1
                If BusObj.Segment(bytSegmentIndex).IRD(bytFieldCounter + 1).fldKey Then
                    strConcatKey = strConcatKey & .Fields(bytFieldCounter).Value
                End If
            Next
            For Each fldToAudit In .Fields
                strSQLInsertAuditAddSeg = "INSERT INTO tblAudit " _
                                    & "(fldLegacyHDRCur, fldLegacyHDRPrv, " _
                                    & "fldAccessReadCur, fldAccessReadPrv, " _
                                    & "fldTableOrForm, fldFieldOrSource, fldControl, " _
                                    & "fldCombinedKey, " _
                                    & "fldUserMUD, fldChangeDate, " _
                                    & "fldValueBefore, fldValueAfter) " _
                                    & "VALUES (" _
                                    & "'" & BusObj.HDREND(1).HDR & "', " _
                                    & "'" & BusObj.HDREND(2).HDR & "', " _
                                    & "'" & BusObj.HDREND(1).ImportDate & "', " _
                                    & "'" & BusObj.HDREND(2).ImportDate & "', " _
                                    & "'" & strCurTableName & "', " _
                                    & "'" & fldToAudit.Name & "', " _
                                    & "'RecAdd', " _
                                    & "'" & strConcatKey & "', " _
                                    & "'" & User.MudID & "', " & "'" & Now() & "', " _
                                    & "'NULL', " _
                                    & "'" & Nz(fldToAudit.Value) & "' );"
                Debug.Print "strSQLInsertAuditAddSeg = "; strSQLInsertAuditAddSeg
                CurrentDb().Execute strSQLInsertAuditAddSeg, dbFailOnError
            Next
            .MoveNext
        Wend
        .Close
    End With
    
'   Execute query for Deleted records and write each record of the recordset to the audit table
    Set rstToAudit = CurrentDb().OpenRecordset _
                    (BusObj.Segment(bytSegmentIndex).Audit.SQLDel, _
                    dbOpenSnapshot, dbDenyWrite, dbReadOnly)
    With rstToAudit
        While Not .EOF
'           Create the record's concatenated key which is required for the audit table
            strConcatKey = ""
            For bytFieldCounter = 0 To .Fields.Count - 1
                If BusObj.Segment(bytSegmentIndex).IRD(bytFieldCounter + 1).fldKey Then
                    strConcatKey = strConcatKey & .Fields(bytFieldCounter).Value
                End If
            Next
            For Each fldToAudit In .Fields
                strSQLInsertAuditDelSeg = "INSERT INTO tblAudit " _
                                    & "(fldLegacyHDRCur, fldLegacyHDRPrv, " _
                                    & "fldAccessReadCur, fldAccessReadPrv, " _
                                    & "fldTableOrForm, fldFieldOrSource, fldControl, " _
                                    & "fldCombinedKey, " _
                                    & "fldUserMUD, fldChangeDate, " _
                                    & "fldValueBefore, fldValueAfter) " _
                                    & "VALUES (" _
                                    & "'" & BusObj.HDREND(1).HDR & "', " _
                                    & "'" & BusObj.HDREND(2).HDR & "', " _
                                    & "'" & BusObj.HDREND(1).ImportDate & "', " _
                                    & "'" & BusObj.HDREND(2).ImportDate & "', " _
                                    & "'" & strPrvTableName & "', " _
                                    & "'" & fldToAudit.Name & "', " _
                                    & "'RecDel', " _
                                    & "'" & strConcatKey & "', " _
                                    & "'" & User.MudID & "', " & "'" & Now() & "', " _
                                    & "'" & Nz(fldToAudit.Value) & "', " _
                                    & "'NULL' );"
                Debug.Print "strSQLInsertAuditDelSeg = "; strSQLInsertAuditDelSeg
                CurrentDb().Execute strSQLInsertAuditDelSeg, dbFailOnError
            Next
            .MoveNext
        Wend
        .Close
    End With
'   Audit Changed segments one field at a time
    For bytFieldCounter = 1 To BusObj.Segment(bytSegmentIndex).FieldCount
        With BusObj.Segment(bytSegmentIndex)
            If Len(.Audit.SQLChg(bytFieldCounter)) < 10 Then GoTo AuditNextField
            Set rstToAudit = CurrentDb().OpenRecordset _
                            (.Audit.SQLChg(bytFieldCounter), _
                                        dbOpenSnapshot, dbDenyWrite)
        End With
        With rstToAudit
            If .EOF Then GoTo NoChangedRecords
            .MoveFirst
            While Not rstToAudit.EOF
                strConcatKey = ""
                For bytFieldCounter2 = 0 To rstToAudit.Fields.Count - 1
                    If Left$(rstToAudit.Fields(bytFieldCounter2).Name, 11) = "fldKeyField" Then
                        strConcatKey = strConcatKey & rstToAudit.Fields(bytFieldCounter2).Value
                    End If
                Next bytFieldCounter2

                strSQLInsertAuditChgSeg = "INSERT INTO tblAudit " _
                                    & "(fldLegacyHDRCur, fldLegacyHDRPrv, " _
                                    & "fldAccessReadCur, fldAccessReadPrv, " _
                                    & "fldTableOrForm, fldFieldOrSource, fldControl, " _
                                    & "fldCombinedKey, " _
                                    & "fldUserMUD, fldChangeDate, " _
                                    & "fldValueBefore, fldValueAfter) " _
                                    & "VALUES (" _
                                    & "'" & BusObj.HDREND(1).HDR & "', " _
                                    & "'" & BusObj.HDREND(2).HDR & "', " _
                                    & "'" & BusObj.HDREND(1).ImportDate & "', " _
                                    & "'" & BusObj.HDREND(2).ImportDate & "', " _
                                    & "'" & strCurTableName & "', " _
                                    & "'" & .Fields(.Fields.Count - 2).SourceField & "', " _
                                    & "'RecChg', " _
                                    & "'" & strConcatKey & "', " _
                                    & "'" & User.MudID & "', " & "'" & Now() & "', " _
                                    & "'" & Nz(.Fields(rstToAudit.Fields.Count - 2).Value) & "', " _
                                    & "'" & Nz(.Fields(rstToAudit.Fields.Count - 1).Value) & "' );"
                    Debug.Print "strSQLInsertAuditChgSeg = "; strSQLInsertAuditChgSeg
                rstToAudit.MoveNext
                CurrentDb().Execute strSQLInsertAuditChgSeg, dbFailOnError
            .MoveNext
            Wend
NoChangedRecords:
        .Close
        End With
AuditNextField:
    Next bytFieldCounter
NormalExit:
    AuditSegment = "OK"
    Exit Function
ReturnFail:
    AuditSegment = "Failed"
End Function


Public Function ReadHDREND(ReadType As Byte) _

                                    As Boolean
'   Read the Header and End record information from the tblIHDREND table.
'   Version 2.0 of SP1Ctrl      199906301705
Dim strSQLSelectIHDREND As String
Dim rstIHDREND As Recordset
Dim strMsg As String
Dim bytCount As Byte
    strHDRCur = ""
    strHDRPrv = ""
    ReadHDREND = False
    strSQLSelectIHDREND = "SELECT * FROM tblIHDREND " _
                        & "WHERE ((tblIHDREND.fldID) = '" _
                        & BusObj.ID & "') " _
                        & "ORDER BY tblIHDREND.fldAcReadDate DESC;"
        Set rstIHDREND = CurrentDb().OpenRecordset(strSQLSelectIHDREND, dbOpenSnapshot)
        With rstIHDREND
            BusObj.PrevImports = CInt(.RecordCount)
            If .EOF Then
                Call ShowMessage("frmMessage", MsgNoHDRENDRecord)
                .Close
                GoTo ReturnFail
            End If
            .MoveLast
            .MoveFirst
            If ((BusObj.PrevImports < 2) And (ReadType = conForImportAudit)) Then      ' non zero-based
                Call ShowMessage("frmMessage", MsgOneHDRENDRecord)
                .Close
                GoTo ReturnFail
            End If
            BusObj.HDREND(1).ImportDate = .Fields(0).Value
            BusObj.HDREND(1).HDRTag = .Fields(2).Value
            BusObj.HDREND(1).CoreID = .Fields(3).Value
            BusObj.HDREND(1).HDRLegApp = .Fields(4).Value
            BusObj.HDREND(1).HDRSiteCode = .Fields(5).Value
            BusObj.HDREND(1).CreateDate = .Fields(6).Value
            BusObj.HDREND(1).CreateTime = .Fields(7).Value
            BusObj.HDREND(1).EndID = .Fields(8).Value
            BusObj.HDREND(1).EndSP = .Fields(9).Value
            BusObj.HDREND(1).EndSite = .Fields(10).Value
            BusObj.HDREND(1).RecordCount = .Fields(11).Value
            With BusObj.HDREND(1)
                .HDR = .HDRTag & .CoreID & .HDRLegApp & .HDRSiteCode _
                        & .CreateDate & .CreateTime
                .END = .EndID & .EndSP & .EndSite & .RecordCount
            End With
            If BusObj.PrevImports >= 2 Then
                .MoveNext
                BusObj.HDREND(2).ImportDate = .Fields(0).Value
                BusObj.HDREND(2).HDRTag = .Fields(2).Value
                BusObj.HDREND(2).CoreID = .Fields(3).Value
                BusObj.HDREND(2).HDRLegApp = .Fields(4).Value
                BusObj.HDREND(2).HDRSiteCode = .Fields(5).Value
                BusObj.HDREND(2).CreateDate = .Fields(6).Value
                BusObj.HDREND(2).CreateTime = .Fields(7).Value
                BusObj.HDREND(2).EndID = .Fields(8).Value
                BusObj.HDREND(2).EndSP = .Fields(9).Value
                BusObj.HDREND(2).EndSite = .Fields(10).Value
                BusObj.HDREND(2).RecordCount = .Fields(11).Value
                With BusObj.HDREND(2)
                    .HDR = .HDRTag & .CoreID & .HDRLegApp & .HDRSiteCode _
                            & .CreateDate & .CreateTime
                    .END = .EndID & .EndSP & .EndSite & .RecordCount
                End With
            Else
                With BusObj.HDREND(2)
                .HDR = "NO PREVIOUS LEGACY EXTRACT"
                .ImportDate = #1/1/99#
                .HDRTag = ""
                .CoreID = ""
                .HDRLegApp = ""
                .HDRSiteCode = ""
                .CreateDate = ""
                .CreateTime = ""
                .EndID = ""
                .EndSP = ""
                .EndSite = ""
                .RecordCount = ""
                .END = .EndID & .EndSP & .EndSite & .RecordCount
                End With
            End If
            .Close
        End With
        
NormalExit:
    ReadHDREND = True
    Exit Function
ReturnFail:
    ReadHDREND = False
End Function


Public Function SetCreateDate4AuditForm() _

                                    As Boolean
Dim strSQLSelectIHDREND As String
Dim rstIHDREND As Recordset
Dim strMsg As String
Dim bytCount As Byte
    strHDRCur = ""
    strHDRPrv = ""
    SetCreateDate4AuditForm = False
    strSQLSelectIHDREND = "SELECT * FROM tblIHDREND " _
                        & "WHERE ((tblIHDREND.fldID) = '" _
                        & pubstrBusObjImpID & "') " _
                        & "ORDER BY tblIHDREND.fldAcReadDate DESC;"
        Set rstIHDREND = CurrentDb().OpenRecordset(strSQLSelectIHDREND, dbOpenSnapshot)
        With rstIHDREND
            If .EOF Then
                pubstrMsg1 = "There is NO record of ANY legacy download " _
                    & "for the selected Business Object"
                pubstrMsg2 = "Therefore an audit record " _
                    & "can not be generated."
'   For wholly manual business objects, two dummy download records are created.
                pubstrMsg3 = "In order to trace the chnaged data back to its source " _
                            & "there must be a record of at least one legacy download file.  " _
                            & "If the selected business object is a wholly manual one, then the " _
                            & "database administrator should see to this problem."
                pubstrMsgIcon = "L" ' sad face
                GoTo ReturnFail
            End If
            .MoveLast
            .MoveFirst
            
            If .RecordCount < 2 Then        ' non zero-based
                dteCurReadDate = .Fields(0).Value
                strCurCreateDate = CStr(.Fields(6).Value) _
                                            & "  " & CStr(.Fields(7).Value)
                For bytCount = 2 To 7
                    strHDRCur = strHDRCur & .Fields(bytCount).Value
                Next
                dtePrvReadDate = #1/1/99#   ' dummy date
                strPrvCreateDate = "NO DATE AVAIL"
                    strHDRPrv = "NO PREVIOUS LEGACY EXTRACT"
                GoTo NormalExit
            End If
            dteCurReadDate = .Fields(0).Value
            strCurCreateDate = CStr(.Fields(6).Value) _
                                        & "  " & CStr(.Fields(7).Value)
            For bytCount = 2 To 7
                strHDRCur = strHDRCur & .Fields(bytCount).Value
            Next
            .MoveNext
                dtePrvReadDate = CStr(.Fields(0).Value)
                strPrvCreateDate = CStr(.Fields(6).Value) _
                                            & "  " & CStr(.Fields(7).Value)
                For bytCount = 2 To 7
                    strHDRPrv = strHDRPrv & .Fields(bytCount).Value
                Next
            .Close
        End With
NormalExit:
    SetCreateDate4AuditForm = True
    Exit Function
ReturnFail:
    SetCreateDate4AuditForm = False
    DoCmd.OpenForm "frmMessage", acNormal, , , acFormReadOnly, acWindowNormal
End Function



Private Function BuildAuditSQLs _

                    (bytSegmentIndex As Byte, strCurTableName As String, strPrvTableName As String) As String
'   Build and store the Insert SQL statements that will be used to select the added/deleted/changed records to audit.
'   Version 2.0 of SP1Ctrl      199906281502
Dim bytFieldCounter As Byte
Dim bytFieldCounter2 As Byte
Dim bytFieldCounter3 As Byte
Dim bytCount As Byte
'   Create Select Query for Added Records dynamically.  That is, test for the key field(s)
'       while the SQL statement is being built-up, so that the key fields can be included.
'   The SQL form is :
'   Select distinctrow * from CUR left join PRV on CUR.Key = PRV.Key where PRV.Key is null
    With BusObj.Segment(bytSegmentIndex)
        .Audit.SQLAdd = "SELECT DISTINCTROW " _
                            & strCurTableName & ".* " _
                            & "FROM " & strCurTableName & " LEFT JOIN " & strPrvTableName _
                            & " ON "
        For bytFieldCounter = 1 To .FieldCount
            If .IRD(bytFieldCounter).fldKey = True Then
                .Audit.SQLAdd = .Audit.SQLAdd _
                                    & " (" _
                                    & strCurTableName & "." & "fld" & .IRD(bytFieldCounter).fldNAME _
                                    & " = " _
                                    & strPrvTableName & "." & "fld" & .IRD(bytFieldCounter).fldNAME _
                                    & " ) AND "
            End If
        Next
'       remove the last "AND" and add the where clause
        .Audit.SQLAdd = Left$(.Audit.SQLAdd, Len(.Audit.SQLAdd) - 4) _
                        & " WHERE ( "
        For bytFieldCounter = 1 To .FieldCount
            If .IRD(bytFieldCounter).fldKey = True Then
                .Audit.SQLAdd = .Audit.SQLAdd _
                                    & " ( " _
                                    & strPrvTableName & "." & "fld" & .IRD(bytFieldCounter).fldNAME _
                                    & " IS NULL " _
                                    & " ) AND "
            End If
        Next
                .Audit.SQLAdd = Left$(.Audit.SQLAdd, Len(.Audit.SQLAdd) - 4) _
                                    & " );"
        Debug.Print ".Audit.SQLAdd = "; .Audit.SQLAdd
    End With

'   Create Select Query for Deleted Records in the form of:
'   Select distinctrow * from PRV left join CUR on PRV.Key = CUR.Key where CUR is Null
    With BusObj.Segment(bytSegmentIndex)
        .Audit.SQLDel = "SELECT DISTINCTROW " _
                            & strPrvTableName & ".* " _
                            & "FROM " & strPrvTableName & " LEFT JOIN " & strCurTableName _
                            & " ON "
        For bytFieldCounter = 1 To .FieldCount
            If .IRD(bytFieldCounter).fldKey = True Then
                .Audit.SQLDel = .Audit.SQLDel _
                                    & " (" _
                                    & strPrvTableName & "." & "fld" & .IRD(bytFieldCounter).fldNAME _
                                    & " = " _
                                    & strCurTableName & "." & "fld" & .IRD(bytFieldCounter).fldNAME _
                                    & " ) AND "
            End If
        Next
'       remove the last "AND" and add the where clause
        .Audit.SQLDel = Left$(.Audit.SQLDel, Len(.Audit.SQLDel) - 4) _
                        & " WHERE ( "
        For bytFieldCounter = 1 To .FieldCount
            If .IRD(bytFieldCounter).fldKey = True Then
            .Audit.SQLDel = .Audit.SQLDel _
                                & " ( " _
                                & strCurTableName & "." & "fld" & .IRD(bytFieldCounter).fldNAME _
                                & " IS NULL " _
                                & " ) AND "
            End If
        Next
            .Audit.SQLDel = Left$(.Audit.SQLDel, Len(.Audit.SQLDel) - 4) _
                                & " );"
            Debug.Print ".Audit.SQLDel = "; .Audit.SQLDel
    End With

'   In the case of changed fields, there must be a query for each field, because selecting CUR.* and PRV.* causes a Record Too Long error.
'   The query is in the form of:
'   Select Distinct CUR.[field name], PRV.[field name] from CUR inner join PRV on CUR.[concatenated Key] = PRV.[concatenated Key]
'   where CUR.[field name] <> PRV.[field name]
    With BusObj.Segment(bytSegmentIndex)
'           The segment type field is excluded
        For bytFieldCounter = 1 To .FieldCount
'   Exclude the Key fields which form part of the WHERE clause
            If .IRD(bytFieldCounter).fldKey Then GoTo NextField
            .Audit.SQLChg(bytFieldCounter) = "SELECT DISTINCT "
'   Select the Key fields and name them as such in the selection query
                For bytFieldCounter2 = 1 To .FieldCount
                    If .IRD(bytFieldCounter2).fldKey Then
                        .Audit.SQLChg(bytFieldCounter) = .Audit.SQLChg(bytFieldCounter) _
                            & strCurTableName & ".fld" & .IRD(bytFieldCounter2).fldNAME _
                            & " AS fldKeyField" & bytFieldCounter2 & " , "
                    End If
                Next bytFieldCounter2
'   Select the identical fields from the Cur and Prv tables
            .Audit.SQLChg(bytFieldCounter) = .Audit.SQLChg(bytFieldCounter) _
                        & strCurTableName & ".fld" _
                        & .IRD(bytFieldCounter).fldNAME & " , " _
                        & strPrvTableName & ".fld" _
                        & .IRD(bytFieldCounter).fldNAME _
                        & " FROM " & strCurTableName & " INNER JOIN " & strPrvTableName _
                        & " ON "
'   Create the ON clause
                For bytFieldCounter3 = 1 To .FieldCount
                    If .IRD(bytFieldCounter3).fldKey Then
                        .Audit.SQLChg(bytFieldCounter) = .Audit.SQLChg(bytFieldCounter) _
                                        & " (" _
                                        & strPrvTableName & "." & "fld" & .IRD(bytFieldCounter3).fldNAME _
                                        & " = " _
                                        & strCurTableName & "." & "fld" & .IRD(bytFieldCounter3).fldNAME _
                                        & " ) AND "
                    End If
                Next
'   remove the last "AND" and add the where clause
                .Audit.SQLChg(bytFieldCounter) = Left$(.Audit.SQLChg(bytFieldCounter), _
                                    Len(.Audit.SQLChg(bytFieldCounter)) - 4) _
                                    & " WHERE ( " _
                                    & strCurTableName & ".fld" _
                                    & .IRD(bytFieldCounter).fldNAME _
                                    & " <> " _
                                    & strPrvTableName & ".fld" _
                                    & .IRD(bytFieldCounter).fldNAME _
                                    & " );"
                
                Debug.Print " .Audit.SQLChg("; bytFieldCounter; ") = "; .Audit.SQLChg(bytFieldCounter)
NextField:
        Next bytFieldCounter
    End With    ' BusObj.Segment(bytSegmentIndex)
    BuildAuditSQLs = "OK"
End Function



Public Function AuditForm _

                            (frmEntryForm As Form, ctlChanged As Control) As String
'   Audits a user entry form when a value is changed.
'   Version 2.0 of SP1Ctrl      199906301818
Dim strConcatKey As String
Dim ctlControl As Control
Dim strSQLAuditForm As String
    AuditForm = ""
    strConcatKey = ""
'   Create the combination Key
    For Each ctlControl In frmEntryForm.Controls
        If Mid$(ctlControl.Name, 1, 6) = "txtKey" Then
            strConcatKey = strConcatKey & Trim$(Nz(ctlControl.Value))
        End If
    Next
    Debug.Print "strConcatKey = "; strConcatKey
    If Len(Nz(strConcatKey)) = 0 Then
            AuditForm = "NO KEY"
            GoTo AuditFormFail
    End If
'   Check for HDREND information
    If ((Len(Nz(BusObj.HDREND(1).HDR))) Or (Len(Nz(BusObj.HDREND(2).HDR)))) = 0 Then
            AuditForm = "CAN NOT AUDIT CHANGE"
            GoTo AuditFormFail
    End If
'   Create the AuditForm SQL
    strSQLAuditForm = "INSERT INTO tblAudit " _
                        & "(fldLegacyHDRCur, fldLegacyHDRPrv, " _
                        & "fldAccessReadCur, fldAccessReadPrv, " _
                        & "fldTableOrForm, fldFieldOrSource, fldControl, " _
                        & "fldCombinedKey, " _
                        & "fldUserMUD, fldChangeDate, " _
                        & "fldValueBefore, fldValueAfter) " _
                        & "VALUES (" _
                        & "'" & BusObj.HDREND(1).HDR & "', " _
                        & "'" & BusObj.HDREND(2).HDR & "', " _
                        & "'" & BusObj.HDREND(1).ImportDate & "', " _
                        & "'" & BusObj.HDREND(2).ImportDate & "', " _
                        & "'" & frmEntryForm.Name & "', " _
                        & "'" & ctlChanged.ControlSource & "', " _
                        & "'" & ctlChanged.Name & "', " _
                        & "'" & strConcatKey & "', " _
                        & "'" & User.MudID & "', " & "'" & Now() & "', " _
                        & "'" & Nz(ctlChanged.OldValue) & "', " _
                        & "'" & Nz(ctlChanged.Value) & "' )"
    Debug.Print "strSQLAuditForm = "; strSQLAuditForm
    CurrentDb().Execute strSQLAuditForm, dbFailOnError
    AuditForm = "OK"
    Exit Function
AuditFormFail:
    AuditForm = AuditForm & " - Audit Failed"
End Function


Public Function AuditDelRecMan _

                                (frmEntryForm As Form) As Boolean
Dim strConcatKey As String
Dim ctlControl As Control
Dim strSQLAuditDelRecMan As String
    strConcatKey = ""
'   Create the combination Key
    For Each ctlControl In frmEntryForm.Controls
        If Mid$(ctlControl.Name, 4, 3) = "Key" Then
            strConcatKey = strConcatKey + ctlControl.Value
        End If
    Next
    Debug.Print "strConcatKey = "; strConcatKey
    
    For Each ctlControl In frmEntryForm.Controls
        If Left$(ctlControl.Name, 3) = "txt" Then
'   Create the AuditForm SQL
        strSQLAuditDelRecMan = "INSERT INTO tblAudit " _
                        & "(fldLegacyHDRCur, fldLegacyHDRPrv, " _
                        & "fldAccessReadCur, fldAccessReadPrv, " _
                        & "fldTableOrForm, fldFieldOrSource, fldControl, " _
                        & "fldCombinedKey, " _
                        & "fldUserMUD, fldChangeDate, " _
                        & "fldValueBefore, fldValueAfter) " _
                        & "VALUES (" _
                        & "'" & strHDRCur & "', " & "'" & strHDRPrv & "', " _
                        & "'" & dteCurReadDate & "', " & "'" & dtePrvReadDate & "', " _
                        & "'" & frmEntryForm.Name & "', " _
                        & "'" & ctlControl.ControlSource & "', " _
                        & "'RecDelForm" & ctlControl.Name & "', " _
                        & "'" & strConcatKey & "', " _
                        & "'" & User.MudID & "', " & "'" & Now() & "', " _
                        & "'" & Nz(ctlControl.Value) & "', " _
                        & "'' )"
'   Execute the SQL here
        Debug.Print "strSQLAuditDelRecMan = "; strSQLAuditDelRecMan
        End If
    Next
    AuditDelRecMan = True
End Function


Public Sub StopIllChar(KeyAscii)

    
    Select Case KeyAscii
        Case Is = 34
            SendKeys "{backspace}"
            GoTo MessageExit
        Case Is = 39
            SendKeys "{backspace}"
            GoTo MessageExit
    End Select
    GoTo NormalExit
MessageExit:
    pubstrMsg1 = "Illegal Character"
    pubstrMsg2 = "You entered a character which is not permissible in the " _
                & "present context.  Type another character instead."
    pubstrMsg3 = "Certain characters, such as a quotation mark or an apostrophe mark " _
                & "can not be used in any field because they interfere with processes " _
                & "such as the audit trail.  You can use other characters instead." _
                & vbCrLf & "For example, you can use ^ instead of an apostrophe mark, " _
                & "and you can replace quotation marks with < > or [ ] or { }."
    pubstrMsgIcon = "L" ' sad face
    DoCmd.OpenForm "frmMessage", acNormal, , , acFormReadOnly, acWindowNormal
NormalExit:
End Sub


Public Function sCreateUser _

            (ByVal strUser As String, ByVal strPID As String, Optional varPwd As Variant) As Integer
'   Create a new user and add them to the Users group
'   Returns True on success, False if user already exists
Dim db As Database
Dim ws As Workspace
Dim usr As User
Dim grpUsers As Group
Dim strSQL As String
'   If password is not supplied, make sure an empty string is passes to the
'   password argument
    If IsMissing(varPwd) Then varPwd = ""
    Set ws = DBEngine.Workspaces(0)
    ws.Users.Refresh
    On Error Resume Next
'   Check to see is user already exists by using inline error handling to trap any errors
'   caused by setting a reference to a possibly non-existent user
    strUser = ws.Users(strUser).Name
    If Err.Number = 0 Then
        MsgBox "the user you are trying to add already exists.", vbInformation, _
                    "Can't Add User"
        sCreateUser = False
    Else
'   go ahead and create the user account
        Set usr = ws.CreateUser(strUser, strPID, varPwd)
        ws.Users.Append usr
        ws.Users.Refresh
'   now add the user to the Users group
        Set grpUsers = ws.Groups("Users")
        Set usr = grpUsers.CreateUser(strUser)
        grpUsers.Users.Append usr
        grpUsers.Users.Refresh
        sCreateUser = True
    End If
End Function


Public Function RestoreChar _

                            (ReplacedString As String) As String
Dim intCharPos As Integer
Dim strChar1 As String * 1
    If Len(ReplacedString) = 0 Then Exit Function
    For intCharPos = 1 To Len(ReplacedString)
        strChar1 = Mid$(ReplacedString, intCharPos, 1)
        Select Case Asc(strChar1)
            Case 135
                Mid$(ReplacedString, intCharPos, 1) = Chr(34)
            Case 165
                Mid$(ReplacedString, intCharPos, 1) = Chr(35)
        End Select
    Next
    RestoreChar = ReplacedString
End Function


Public Sub SetBOIRD()

'   Setting the .IRD array element of the segment array element of the current business object.
'   Version 2 of SP1Ctrl.mdw  199906240831
Dim rstSegments As Recordset
Dim rstSegmentFields As Recordset
Dim intSegmentCounter As Integer
Dim intFieldCounter As Integer
Dim strSQLSegmentTypes As String
'SELECT DISTINCT tblBOIRD.fldID
'FROM tblBOIRD
'WHERE (((tblBOIRD.fldID) Like "034DAPS01*"))
'ORDER BY tblBOIRD.fldID;
    strSQLSegmentTypes = "SELECT DISTINCT tblBOIRD.fldID FROM tblBOIRD " _
                        & "WHERE ((tblBOIRD.fldID) Like '" & BusObj.ID & "*') " _
                        & "ORDER BY tblBOIRD.fldID;"

    Set rstSegments = CurrentDb().OpenRecordset(strSQLSegmentTypes, _
                        dbOpenSnapshot, dbDenyWrite, dbReadOnly)
    With rstSegments
        .MoveLast
        .MoveFirst
        BusObj.SegmentCount = .RecordCount   ' Including HDR and END
        intSegmentCounter = 0
        While Not .EOF
            intSegmentCounter = intSegmentCounter + 1
            BusObj.Segment(intSegmentCounter).SegmentID = Right$(.Fields(0), 3)
            BusObj.Segment(intSegmentCounter).SQLSelectIRD = _
                "SELECT * FROM tblBOIRD WHERE" _
                & " ((Left$(fldID,9) = " _
                & "'" & Left$(BusObj.ID, 9) & "') " _
                & "AND (Right$(fldID,3) = " _
                & "'" & Right$(.Fields(0), 3) & "')) " _
                & "ORDER BY [fldSortOrder];"
            Debug.Print Now(), _
                "BusObj.Segment("; intSegmentCounter; ").SQLSelectIRD  = "; _
                BusObj.Segment(intSegmentCounter).SQLSelectIRD
            .MoveNext
        Wend
        .Close
    End With
    
    
    For intSegmentCounter = 1 To BusObj.SegmentCount
        Set rstSegmentFields = CurrentDb().OpenRecordset _
                (BusObj.Segment(intSegmentCounter).SQLSelectIRD, dbOpenSnapshot)
        rstSegmentFields.MoveLast
        rstSegmentFields.MoveFirst
        BusObj.Segment(intSegmentCounter).FieldCount = rstSegmentFields.RecordCount
        intFieldCounter = 0
        While Not rstSegmentFields.EOF
            intFieldCounter = intFieldCounter + 1
            With BusObj.Segment(intSegmentCounter).IRD(intFieldCounter)
                .fldID = rstSegmentFields.Fields(0).Value
                .fldSortOrder = rstSegmentFields.Fields(1).Value
                .fldNAME = rstSegmentFields.Fields(3).Value
                .fldDescription = Nz(rstSegmentFields.Fields(4).Value)
                .fldStartPosition = rstSegmentFields.Fields(8).Value
                .fldLength = rstSegmentFields.Fields(6).Value
                .fldManElec = rstSegmentFields.Fields(12).Value
                .fldSetTo = Nz(rstSegmentFields.Fields(13).Value)
                .fldKey = rstSegmentFields.Fields(14).Value
                .fldManUpdateCrit = rstSegmentFields.Fields(15).Value
                    Debug.Print Now(), _
                            "BusObj.Segment("; intSegmentCounter; ").IRD("; intFieldCounter; ") = "; "     " _
                            ; .fldID; "     " _
                            ; .fldSortOrder; "     " _
                            ; .fldNAME; "     " _
                            ; .fldDescription; "     " _
                            ; .fldStartPosition; "     " _
                            ; .fldLength; "     " _
                            ; .fldManElec; "     " _
                            ; .fldSetTo; "     " _
                            ; .fldKey; "     " _
                            ; .fldManUpdateCrit
            End With
            BusObj.Segment(intSegmentCounter).BOIRDAssigned = True
            rstSegmentFields.MoveNext
        Wend
        rstSegmentFields.Close
    Next
    
End Sub


Public Sub ShowMessage(strFormName As String, MsgID As Integer)

' Display numbered messages from the Message table tblMessage
Dim rstMessage As Recordset
    Set rstMessage = CurrentDb().OpenRecordset _
            ("select * from tblMessage where fldMsgID = " _
            & MsgID, dbOpenSnapshot)
    With rstMessage
        pubstrMsg1 = Nz(.Fields(1))
        pubstrMsg2 = Nz(.Fields(2))
        pubstrMsg3 = Nz(.Fields(3))
        pubstrMsgIcon = Nz(.Fields(4))
        .Close
    End With
    DoCmd.OpenForm strFormName, acNormal, , , acFormReadOnly, acWindowNormal
End Sub


Private Function CheckHEADEND() _

                            As String
'   Check the HDR and END records, set BusObj.HDREND(1) and place them in the tblHDREND
'   Version 2.0 of SP1Ctrl      199906240914
Dim rstHdrEnd As Recordset
Dim strHeadEnd As String
Dim strHeadEndSQL As String
Dim lngFileLineCount As Long
Dim intITextLineCount As Long
Dim intIEndCount As Long

Const conHDRRecLength = 28
Const conENDRecLength = 21
    Call ShowMessage("frmMessageProgress", MsgCkechHDRENDProgress)
    CheckHEADEND = "ERROR"
    Close
    Open BusObj.FileNamePath For Input Access Read As #1
        Line Input #1, strImpRecord
        If Left$(strImpRecord, 3) <> "HDR" Then
            CheckHEADEND = "The First Record is NOT a header record"
            GoTo ExitError
        End If
        If Len(strImpRecord) < conHDRRecLength Then
            CheckHEADEND = "The HEADER record is shorter than the expected " _
                    & conHDRRecLength & " characters."
        GoTo ExitError
        End If
        Forms!frmMessageProgress!cmdCancel.SetFocus
        strHeadEnd = Left$(strImpRecord, conHDRRecLength)
        intITextLineCount = 1
        lngFileLineCount = LOF(1) / Len(strImpRecord)
        While Not EOF(1)
        Line Input #1, strImpRecord
            intITextLineCount = intITextLineCount + 1
'   Start of progress indicator
            pubstrMsg2 = "Reading line " & Format(intITextLineCount, "#,##0") _
                & " of " & Format(lngFileLineCount, "#,##0")
            Forms!frmMessageProgress!lblMsg2.Caption = pubstrMsg2
            DoCmd.RepaintObject acForm, "frmMessageProgress"
'   End of progress indicator
            If Left$(strImpRecord, 3) = "END" Then
                intIEndCount = Val(Mid(strImpRecord, 12, 10))
                strHeadEnd = strHeadEnd + Left$(strImpRecord, conENDRecLength)
            End If
        Wend
    Close #1
        If Len(strHeadEnd) < conHDRRecLength + conENDRecLength Then
            CheckHEADEND = "The END record is missing or shorter than the expected " _
                    & conENDRecLength & " characters."
            GoTo ExitError
        End If
        If intITextLineCount <> intIEndCount Then
            CheckHEADEND = "The Record Count in the import file " _
                        & "does not match the record count " _
                        & "indicated in the END record.  " _
                        & "This could also be due to blank line(s) " _
                        & "within the import file. "
            GoTo ExitError
        End If
        
    DoCmd.Close acForm, "frmMessageProgress"
'   Set the header-end for the last import
    With BusObj.HDREND(0)
        .HDR = Left$(strHeadEnd, conHDRRecLength)
        .END = Right$(strHeadEnd, conENDRecLength)
        .ImportDate = Now()
        .HDRTag = Mid$(strHeadEnd, 1, 3)
        .CoreID = Mid$(strHeadEnd, 4, 3)
        .HDRLegApp = Mid$(strHeadEnd, 7, 2)
        .EndSite = Mid$(strHeadEnd, 9, 6)
        .CreateDate = Mid$(strHeadEnd, 15, 8)
        .CreateTime = Mid$(strHeadEnd, 23, 6)
        .EndID = Mid$(strHeadEnd, 29, 3)
        .EndSP = Mid$(strHeadEnd, 32, 2)
        .EndSite = Mid$(strHeadEnd, 34, 6)
        .RecordCount = Mid$(strHeadEnd, 40, 10)
        strHeadEndSQL = "INSERT INTO tblIHDREND " _
                        & "(fldAcReadDate, fldID, fldHDRFITAG, fldHDRDOTYP, " _
                        & "fldHDRFINUM, fldHDRSTEID, fldHDRDOCCD, fldHDRDOCTI, " _
                        & "fldENDFITAG, fldENDFINUM, fldENDSTEID, fldENDRECNT )" _
                        & "VALUES (" _
                        & "'" & .ImportDate & "', " _
                        & "'" & BusObj.ID & "', " _
                        & "'" & .HDRTag & "', " _
                        & "'" & .CoreID & "', " _
                        & "'" & .HDRLegApp & "', " _
                        & "'" & .EndSite & "', " _
                        & "'" & .CreateDate & "', " _
                        & "'" & .CreateTime & "', " _
                        & "'" & .EndID & "', " _
                        & "'" & .EndSP & "', " _
                        & "'" & .EndSite & "', " _
                        & "'" & .RecordCount & "' ); "
    End With
    Debug.Print Now(), "strHeadEndSQL = "; strHeadEndSQL
    CurrentDb().Execute strHeadEndSQL, dbFailOnError
'   Find the number of previous imports for this business object
    strHeadEndSQL = "SELECT * FROM tblIHDREND WHERE (fldID = '" & BusObj.ID & "');"
    Set rstHdrEnd = CurrentDb().OpenRecordset _
                        (strHeadEndSQL, dbOpenSnapshot, dbReadOnly)
    With rstHdrEnd
        .MoveLast
        BusObj.PrevImports = CInt(.RecordCount)
        .Close
    End With
    
    GoTo ExitOK
ExitError:
    Close #1
    DoCmd.Close acForm, "frmMessageProgress"
        Debug.Print Now(), "intITextLineCount = "; intITextLineCount
        Debug.Print Now(), "intIEndCount = "; intIEndCount
        Debug.Print Now(), "strHeadEnd = "; strHeadEnd
        Debug.Print Now(), "strHeadEndSQL = "; strHeadEndSQL
    Call ShowMessage("frmMessage", MsgCkechHDRENDProblem)
    Forms!frmMessage!lblMsg2.Caption = CheckHEADEND
    DoCmd.RepaintObject acForm, "frmMessageProgress"
    Exit Function
ExitOK:
    CheckHEADEND = "OK"
End Function


Private Function BusObjSegmentToCurTable() _

                                                As Boolean
'   Transfer data from *TxtCur table to tables tables created to hold data for each segment.
'   Function in ModImport in SP1Ctrl.mdb Version 2.0    199906250942
Dim rstImportTxtCur As Recordset
Dim strTablenameTxtCur As String
Dim strTableNameSegCur As String
Dim strIRecordType As String
Dim strInsertSQL As String
Dim bytSegmentCounter As Byte
Dim bytSegmentIndex As Byte
Dim bytFieldCounter As Byte
Dim strSQLSegTxtCur As String
Dim strSQLMakeTableSegCur As String
    BusObjSegmentToCurTable = False
    strTablenameTxtCur = "tblI" & BusObj.ID & "TxtCur"
    Call ShowMessage("frmMessageProgress", conMsgSegmentProcessing)
        pubstrMsg3 = "If you decide to interupt this process, all tables of the form " _
                    & vbCrLf & Left$(strTablenameTxtCur, 13) & "*CUR" & vbCrLf _
                    & " will be incomplete and therefore will need to be deleted." _
                    & vbCrLf & "You can restart the import process after you delete the" _
                    & " incomplete tables, otherwise existing data may be lost."
        Forms!frmMessageProgress!lblMsg3.Caption = pubstrMsg3
        Forms!frmMessageProgress!cmdCancel.SetFocus
        DoCmd.RepaintObject acForm, "frmMessageProgress"
    For bytSegmentIndex = 1 To BusObj.SegmentCount
        With BusObj.Segment(bytSegmentIndex)
            strSQLMakeTableSegCur = "SELECT "
            For bytFieldCounter = 1 To .FieldCount
                strSQLMakeTableSegCur = strSQLMakeTableSegCur _
                    & "mid$([" & strTablenameTxtCur & "].[fld" & BusObj.ID & "TxtCur]," _
                    & .IRD(bytFieldCounter).fldStartPosition & " , " _
                    & .IRD(bytFieldCounter).fldLength _
                    & ")  AS fld" & .IRD(bytFieldCounter).fldNAME & ", "
            Next
            strSQLMakeTableSegCur = Left$(strSQLMakeTableSegCur, Len(strSQLMakeTableSegCur) - 2) _
                & " INTO tblI" & BusObj.ID & .SegmentID & "Cur" _
                & " FROM " & strTablenameTxtCur _
                & " WHERE ((left$([" & strTablenameTxtCur & "].[fld" & BusObj.ID & "TxtCur],1) " _
                & "= left$('" & .SegmentID & "', 1)) " _
                & "OR (left$([" & strTablenameTxtCur & "].[fld" & BusObj.ID & "TxtCur],1) " _
                & "= right$('" & .SegmentID & "', 1)));"
                
'   Start of progress indicator
                    pubstrMsg2 = "Processing Segment " & .SegmentID _
                        & " of " & BusObj.ID & " - " & BusObj.Name
                    Forms!frmMessageProgress!lblMsg2.Caption = pubstrMsg2
                    DoCmd.RepaintObject acForm, "frmMessageProgress"
'   End of progress indicator
                    Debug.Print "Segment = "; .SegmentID
                    Debug.Print "strSQLMakeTableSegCur = "; strSQLMakeTableSegCur
        End With
    CurrentDb().Execute strSQLMakeTableSegCur, dbFailOnError
    Next
    DoCmd.Close acForm, "frmMessageProgress"
    GoTo NormalExit
NextRecord:
NormalExit:
    BusObjSegmentToCurTable = True
    Exit Function
ExitError:
    BusObjSegmentToCurTable = False
End Function


Private Function BuildSegCurInsertSQL _

                                    (bytSegmentIndex As Byte) As String
Dim strTableName As String
Dim bytFieldCounter As Byte
    strTableName = "tblI" & BusObj.ID & BusObj.Segment(bytSegmentIndex).SegmentID & "Cur"
    
    With BusObj.Segment(bytSegmentIndex)
        BuildSegCurInsertSQL = "INSERT INTO " & strTableName & "("
        For bytFieldCounter = 1 To .FieldCount
            BuildSegCurInsertSQL = BuildSegCurInsertSQL & "fld" & .IRD(bytFieldCounter).fldNAME & ", "
        Next bytFieldCounter
        BuildSegCurInsertSQL = Left$(BuildSegCurInsertSQL, Len(BuildSegCurInsertSQL) - 2) _
                & ") "
            BuildSegCurInsertSQL = BuildSegCurInsertSQL & "VALUES ("
        For bytFieldCounter = 1 To .FieldCount
            BuildSegCurInsertSQL = BuildSegCurInsertSQL _
                & "'" _
                & Nz(Mid$(strImpRecord, _
                    .IRD(bytFieldCounter).fldStartPosition, _
                    .IRD(bytFieldCounter).fldLength)) _
                & "' , "
        Next bytFieldCounter
        BuildSegCurInsertSQL = Left$(BuildSegCurInsertSQL, Len(BuildSegCurInsertSQL) - 2) _
                & ") "
        Debug.Print Now(), "BuildSegCurInsertSQL = "; BuildSegCurInsertSQL
    End With
End Function


Public Function SetUserInfo() _

                        As Boolean
'   Set the user information to the CurrentUserInfo Type
'   Version 2.0 of SP1Ctrl      199906301250
    On Error GoTo ExitError
    With User
        .Lastname = CurrentUser()
        .Firstname = DLookup("fldValidUserFirstname", "tblValidUserList", "fldValidUserLastname = CurrentUser()")
        .MudID = DLookup("fldValidUserMud", "tblValidUserList", "fldValidUserLastname = CurrentUser()")
        If Len(.MudID) = 0 Then GoTo ExitError
    End With
NormalExit:
    On Error GoTo 0
    SetUserInfo = True
    Exit Function
ExitError:
    On Error GoTo 0
    SetUserInfo = False
    Call ShowMessage("frmMessage", conMsgNoUserInfo)
End Function
                        



 

Please click on the link below to return to the English Home Page

If you require some further information, Please Contact Me

Return to English Home Page

Return to Work Samples

Copyright © 1999 Dr. M. A. Meshkot
This page was last updated May 2004