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.
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()
' 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
'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
' 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
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
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
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
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
() 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
(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
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
' 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
(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
' 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
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
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
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
(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
(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
(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
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
(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
(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
' 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
' 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
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
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
(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
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
Copyright © 1999 Dr. M. A. Meshkot
This page was last updated May 2004