'--------------------------------------------------------------------------------
' Procedure......: UpdateDBReferenceHandling
' Author.........: Ralf Kunsmann
' Date...........: 2007 02 22
' Purpose........: DB tables have a text-field ('RUID') as primary key, having
'                  28 characters length. Fields have to be updated to have 50
'                  chars length.
'                  For fields are part of releations and DAO is not able to
'                  redefine field sizes, 1st it was planed remove relations,
'                  update field sizes and restore relations.
'                  But this was not feasible because of an error in Jet-Engine
'                  (sweat!): Relations couldn't be removed. So the only
'                  solution is to copy the complete database (design and
'                  contents).
' Parameters.....: Object instance of opened (original) database.
'--------------------------------------------------------------------------------
Public Sub UpdateDBReferenceHandling(db As Database)

    Const sPROCEDURENAME As String = "UpdateDBReferenceHandling"
    On Error GoTo ErrorUpdateDBReferenceHandling

' Stuff was already done? Exit!
    If UpdateDBReferenceHandlingDone(db) Then Exit Sub

' Get names of all relations to a dictionary
    Dim dicRel As Dictionary: Set dicRel = New Dictionary
    Dim rel As Relation
    For Each rel In db.Relations
        dicRel.Add rel.Name, rel.Name
    Next

    Dim sDbPath As String: sDbPath = db.Name

' Create new Access database
    Dim sNewDBPath As String: sNewDBPath = Replace(sDbPath, ".mdb", "New.mdb")
    If ExistFile(sNewDBPath) Then Kill sNewDBPath
    Dim dbNew As Database: Set dbNew = CreateDatabase(sNewDBPath, dbLangGeneral)

' All tables in original database, except access' own management tables ...
    Dim td As TableDef, tdNew As TableDef
    Dim fld As Field, fldNew As Field
    Dim idx As Index, idxNew As Index
    For Each td In db.TableDefs
        If InStr(td.Name, "MSys") = 0 Then
        ' Create new table in new database
            Set tdNew = New TableDef
            tdNew.Name = td.Name
            For Each fld In td.Fields
            ' Append new fields to new table based on fields in original table
                Set fldNew = New Field
                fldNew.Name = fld.Name
                fldNew.Type = fld.Type
                If fld.Type = dbText Or fld.Type = dbMemo Then _
                    fldNew.AllowZeroLength = fld.AllowZeroLength
                fldNew.Attributes = fld.Attributes
                fldNew.DefaultValue = fld.DefaultValue
                fldNew.OrdinalPosition = fld.OrdinalPosition
                fldNew.Required = fld.Required
                fldNew.Size = IIf(InStr(fld.Name, "RUID") > 0, 50, fld.Size)
                fldNew.ValidationRule = fld.ValidationRule
                fldNew.ValidationText = fld.ValidationText
                tdNew.Fields.Append fldNew
            Next
            For Each idx In td.Indexes
            ' Append new indices to new table based on indices in original table.
            ' Exclude the indices, that are part of the relations.
                If Not dicRel.Exists(idx.Name) Then
                    Set idxNew = New Index
                    idxNew.Clustered = idx.Clustered
                    idxNew.Fields = idx.Fields
                    idxNew.IgnoreNulls = idx.IgnoreNulls
                    idxNew.Name = idx.Name
                    idxNew.Primary = idx.Primary
                    idxNew.Required = idx.Required
                    idxNew.Unique = idx.Unique
                    tdNew.Indexes.Append idxNew
                End If
            Next
            dbNew.TableDefs.Append tdNew
        End If
    Next

' Copy the relations
    Dim relNew As Relation
    For Each rel In db.Relations
        Set relNew = dbNew.CreateRelation(rel.Name, rel.Table, rel.ForeignTable, rel.Attributes)
        Set fldNew = relNew.CreateField(rel.Fields(0).Name)
        fldNew.ForeignName = rel.Fields(0).ForeignName
        relNew.Fields.Append fldNew
        dbNew.Relations.Append relNew
    Next

' Copy QueryDefs
    Dim qd As QueryDef, qdNew As QueryDef
    For Each qd In db.QueryDefs
        Set qdNew = dbNew.CreateQueryDef(qd.Name, qd.SQL)
    ' Idiotic: In contrast to Tables, Fields, Indices, Relations, ...
    '          no Append() necessary or even alowed for QueryDefs
    Next

' Copy all records from old to new database
    If Not CopyData(db, dbNew) Then
    ' If this was not successful, display messagebox, close and remove new database
        gsMsg = "The necessary database update failed." & vbCrLf & vbCrLf & _
                "Please contact software vendor!"
        MsgBox gsMsg, vbInformation, gUI.FMain.Caption
        dbNew.Close
        Kill sNewDBPath
        Exit Sub
    End If

' Close old and new database
    db.Close
    dbNew.Close

' Get file path for a backup of old database
    Dim sOldDBPath As String: sOldDBPath = Replace(sDbPath, ".mdb", "Old.mdb")

' Backup old database
    CopyAnyFile sDbPath, sOldDBPath
    Kill sDbPath

' Make new database to current database
    CopyAnyFile sNewDBPath, sDbPath
    Kill sNewDBPath

' Open the new database
    Set db = OpenDatabase(sDbPath)

    Exit Sub

ErrorUpdateDBReferenceHandling:
#If afDebug Then
    Debug.Print GetErrorInfo(Err)
    Stop
    Resume
#End If
' Show error message
    DisplayErrorMsg "Could not run action to end. Reason: ", _
                    Err.Number, Err.Description, msMODULENAME, sPROCEDURENAME, Erl
End Sub

    Dim sNewDBPath As String: sNewDBPath = Replace(sDbPath, ".mdb", "New.mdb")

    Dim sNewDBPath As String = Replace(sDbPath, ".mdb", "New.mdb")

    Dim sNewDBPath As String
    sNewDBPath = Replace(sDbPath, ".mdb", "New.mdb")

'--------------------------------------------------------------------------------
' Procedure......: UpdateDBReferenceHandlingDone
' Author.........: Ralf Kunsmann
' Date...........: 2007 02 22
' Purpose........: Check, if Reference Handling update is already done.
' Hint...........: It's done if the field size is '50'
'--------------------------------------------------------------------------------
Private Function UpdateDBReferenceHandlingDone(db As Database) As Boolean

    Dim td As TableDef: Set td = GetDatabaseTable(db, "ToolTypes")
    Dim fld As Field: Set fld = GetDatabaseField(td, "RUID")
    UpdateDBReferenceHandlingDone = fld.Size = 50

End Function

'--------------------------------------------------------------------------------
' Procedure......: GetDatabaseTable
' Author.........: Ralf Kunsmann
' Date...........: 2002 12 09
' Purpose........: Get reference to a certain table in a database.
' Result.........: On success: Object reference to table, else Nothing
' In parameters..: Object Reference: Database
'                  String: Name of table
'--------------------------------------------------------------------------------
Public Function GetDatabaseTable(Database As Database, TableName As String) As TableDef

#If Not afDebug Then
    On Error Resume Next
#End If
    Dim td As TableDef

    For Each td In Database.TableDefs
        If td.Name = TableName Then
            Set GetDatabaseTable = td
            Exit Function
        End If
    Next

    Set GetDatabaseTable = Nothing

End Function

'--------------------------------------------------------------------------------
' Procedure......: GetDatabaseField
' Author.........: Ralf Kunsmann
' Date...........: 2002 12 09
' Purpose........: Get reference to a certain field in a database table.
' Result.........: On success: Object reference to field, else Nothing
' In parameters..: Object Reference: Database table
'                  String: Name of field
'--------------------------------------------------------------------------------
Public Function GetDatabaseField(TD As TableDef, FLD As String) As Field

#If Not afDebug Then
    On Error Resume Next
#End If
    Dim fld As Field
    For Each fld In TD.Fields
        If fld.Name = FLD Then
            Set GetDatabaseField = fld
            Exit Function
        End If
    Next

    Set GetDatabaseField = Nothing

End Function

'--------------------------------------------------------------------------------
' Procedure......: CopyData
' Author.........: Ralf Kunsmann
' Date...........: 2007 02 26
' Purpose........: Copy all records of all tables from old to new database.
' Hint...........: Ordner is not by chance. Relations must be considered.
'--------------------------------------------------------------------------------
Private Function CopyData(db As Database, dbNew As Database) As Boolean

    Const sPROCEDURENAME As String = "CopyData"
    On Error GoTo ErrorCopyData

    If Not CopyTableData(db, dbNew, "Devices") Then Exit Function
    If Not CopyTableData(db, dbNew, "DevicesDefault") Then Exit Function
    If Not CopyTableData(db, dbNew, "DevicesMflSh") Then Exit Function
    If Not CopyTableData(db, dbNew, "DevicesMflShChannels") Then Exit Function
    If Not CopyTableData(db, dbNew, "ToolTypes") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigUses") Then Exit Function
    If Not CopyTableData(db, dbNew, "Configs") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigsDefault") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigsOptionPack") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigSecs") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigSecsDefault") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigSecsDefaultPc") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigSecsDefaultSc") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigDetails") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigDetailsDefault") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigDetailsDefaultFlightRec") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigDetailsMflSenSeq") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigDetailsScMfl") Then Exit Function
    If Not CopyTableData(db, dbNew, "ConfigDetailsScMflSh") Then Exit Function
    If Not CopyTableData(db, dbNew, "Projects") Then Exit Function
    If Not CopyTableData(db, dbNew, "ItemValuesBoolean") Then Exit Function
    If Not CopyTableData(db, dbNew, "ItemValuesDouble") Then Exit Function
    If Not CopyTableData(db, dbNew, "ItemValuesLong") Then Exit Function
    If Not CopyTableData(db, dbNew, "ItemValuesText") Then Exit Function
    If Not CopyTableData(db, dbNew, "MN_Configs_Projects") Then Exit Function
    If Not CopyTableData(db, dbNew, "Version") Then Exit Function

    CopyData = True
    Exit Function

ErrorCopyData:
#If afDebug Then
    Debug.Print GetErrorInfo(Err)
    Stop
    Resume
#End If
' Remember: Don't risk to change Err object contents before it's read!!!
    Dim sErr As String, iErr As Long
    sErr = Err.Description: iErr = Err.Number
    Err.Raise iErr, msMODULENAME & "." & sPROCEDURENAME, sErr
End Function

'--------------------------------------------------------------------------------
' Procedure......: CopyTableData
' Author.........: Ralf Kunsmann
' Date...........: 2007 02 26
' Purpose........: Copy records of a certain database table from one database
'                  to another.
'--------------------------------------------------------------------------------
Public Function CopyTableData(dbSource As Database, _
                              dbTarget As Database, _
                              TableName As String) As Boolean

    Const sPROCEDURENAME As String = "CopyTableData"
    On Error GoTo ErrorCopyTableData

    gUI.DisplayStateMsg "Copying table " & TableName & " ..."
    Dim rsSource As Recordset
    Set rsSource = dbSource.OpenRecordset(TableName, dbOpenSnapshot)
    Dim rsTarget As Recordset
    Set rsTarget = dbTarget.OpenRecordset(TableName, dbOpenDynaset)

    Do While Not rsSource.EOF
        rsTarget.AddNew
        If Not CopyRecordsetData(rsSource, rsTarget, False) Then Exit Function
        rsTarget.Update
        rsSource.MoveNext
    Loop

    CopyTableData = True
    Exit Function

ErrorCopyTableData:
#If afDebug Then
    Debug.Print GetErrorInfo(Err)
    Stop
    Resume
#End If
' Remember: Don't risk to change Err object contents before it's read!!!
    Dim sErr As String, iErr As Long
    sErr = Err.Description: iErr = Err.Number
    Err.Raise iErr, msMODULENAME & "." & sPROCEDURENAME, sErr
End Function

'--------------------------------------------------------------------------------
' Procedure.....: CopyRecordsetData
' Author........: Ralf Kunsmann
' Date..........: 2001 06 22
' Purpose.......: Copy VisiPIG project data from one recordset to another (Part
'                 of work, when complete projects are copied).
' Result........: True on success, else False
' In parameters.: Recordset with the source data;
'                 Recordset where data has to be copied to;
'                 Boolean saying, if the target recordset has to be set to edit
'                 mode before copying (and has to be updated at the end of work).
'--------------------------------------------------------------------------------
Public Function CopyRecordsetData(rsSource As Recordset, _
                                  rsTarget As Recordset, _
                                  EditAndUpdate As Boolean) As Boolean

    Const sPROCEDURENAME As String = "CopyRecordsetData"
    Dim fld As Field

    On Error GoTo ErrorCopyRecordsetData

    If EditAndUpdate Then rsTarget.Edit
    For Each fld In rsTarget.Fields
        If Not (fld.Attributes And dbAutoIncrField) = dbAutoIncrField Then _
            rsTarget(fld.Name) = rsSource(fld.Name)
    Next
    If EditAndUpdate Then rsTarget.Update

    CopyRecordsetData = True
    Exit Function

ErrorCopyRecordsetData:
' It can easily be the case that a field is target database in not present in
' source database. This can be ignored becouse the field contents will be set
' to the default value.
    If Err.Number = 3265 Then Resume Next ' Item not found in collection.
#If afDebug Then
    Debug.Print GetErrorInfo(Err)
    Stop
    Resume
#End If
    Dim sErr As String, iErr As Long
    sErr = Err.Description: iErr = Err.Number
    Err.Raise iErr, msMODULENAME & "." & sPROCEDURENAME, sErr
End Function

'--------------------------------------------------------------------------------
' Procedure......: GetErrorInfo
' Author.........: Ralf Kunsmann
' Date...........: 2004 10 12
' Purpose........: Extract information about a code error from the Error object.
'--------------------------------------------------------------------------------
Public Function GetErrorInfo(Err As ErrObject) As String

    Const iCOMERRMASK                 As Long = &H7000FFFF
    Const iFACILITYMASK               As Long = &HF0000
    Const iFACILITY_AAF               As Long = 18  '  00000010010
    Const iFACILITY_ACS               As Long = 20  '  00000010100
    Const iFACILITY_BACKGROUNDCOPY    As Long = 32  '  00000100000
    Const iFACILITY_CERT              As Long = 11  '  00000001011
    Const iFACILITY_COMPLUS           As Long = 17  '  00000010001
    Const iFACILITY_CONFIGURATION     As Long = 33  '  00000100001
    Const iFACILITY_CONTROL           As Long = 10  '  00000001010
    Const iFACILITY_DISPATCH          As Long = 2   '  00000000010
    Const iFACILITY_DPLAY             As Long = 21  '  00000010101
    Const iFACILITY_HTTP              As Long = 25  '  00000011001
    Const iFACILITY_INTERNET          As Long = 12  '  00000001100
    Const iFACILITY_ITF               As Long = 4   '  00000000100
    Const iFACILITY_MEDIASERVER       As Long = 13  '  00000001101
    Const iFACILITY_MSMQ              As Long = 14  '  00000001110
    Const iFACILITY_NULL              As Long = 0   '  00000000000
    Const iFACILITY_RPC               As Long = 1   '  00000000001
    Const iFACILITY_SCARD             As Long = 16  '  00000010000
    Const iFACILITY_SECURITY          As Long = 9   '  00000001001
    Const iFACILITY_SETUPAPI          As Long = 15  '  00000001111
    Const iFACILITY_SSPI              As Long = 9   '  00000001001
    Const iFACILITY_STORAGE           As Long = 3   '  00000000011
    Const iFACILITY_SXS               As Long = 23  '  00000010111
    Const iFACILITY_UMI               As Long = 22  '  00000010110
    Const iFACILITY_URT               As Long = 19  '  00000010011
    Const iFACILITY_WIN32             As Long = 7   '  00000000111
    Const iFACILITY_WINDOWS           As Long = 8   '  00000001000
    Const iFACILITY_WINDOWS_CE        As Long = 24  '  00000011000
    Dim iNumber As Long
    Dim iFacility As Long
    Dim sSource As String
    Dim sDescription As String
    Dim sErr As String

' Get info from Error object
    iNumber = Err.Number
    sSource = Err.Source
    sDescription = Err.Description

' Activate error handle only now (because it will reset the Err object)
    On Error Resume Next

' Extract facility and error number (COM errors contain 1 in MS bit)
    iFacility = (iNumber And iFACILITYMASK) / &H10000
    iNumber = iNumber And iCOMERRMASK

' Get source
    sErr = "   Source: " & sSource & vbCrLf & "   Facility: "

' Get facility
    Select Case iFacility
    Case iFACILITY_AAF:            sErr = sErr & "AAF" & vbCrLf
    Case iFACILITY_ACS:            sErr = sErr & "ACS" & vbCrLf
    Case iFACILITY_BACKGROUNDCOPY: sErr = sErr & "BACKGROUNDCOPY" & vbCrLf
    Case iFACILITY_CERT:           sErr = sErr & "CERT" & vbCrLf
    Case iFACILITY_COMPLUS:        sErr = sErr & "COMPLUS" & vbCrLf
    Case iFACILITY_CONFIGURATION:  sErr = sErr & "CONFIGURATION" & vbCrLf
    Case iFACILITY_CONTROL:        sErr = sErr & "Control" & vbCrLf
    Case iFACILITY_DISPATCH:       sErr = sErr & "DISPATCH" & vbCrLf
    Case iFACILITY_DPLAY:          sErr = sErr & "DPLAY" & vbCrLf
    Case iFACILITY_HTTP:           sErr = sErr & "HTTP" & vbCrLf
    Case iFACILITY_INTERNET:       sErr = sErr & "INTERNET" & vbCrLf
    Case iFACILITY_ITF:            sErr = sErr & "ITF" & vbCrLf
    Case iFACILITY_MEDIASERVER:    sErr = sErr & "MEDIASERVER" & vbCrLf
    Case iFACILITY_MSMQ:           sErr = sErr & "MSMQ" & vbCrLf
    Case iFACILITY_NULL:           sErr = sErr & "Undefined" & vbCrLf
    Case iFACILITY_RPC:            sErr = sErr & "RPC" & vbCrLf
    Case iFACILITY_SCARD:          sErr = sErr & "SCARD" & vbCrLf
    Case iFACILITY_SECURITY:       sErr = sErr & "SECURITY or SSPI" & vbCrLf
    Case iFACILITY_SETUPAPI:       sErr = sErr & "SETUPAPI" & vbCrLf
    Case iFACILITY_STORAGE:        sErr = sErr & "STORAGE" & vbCrLf
    Case iFACILITY_SXS:            sErr = sErr & "SXS" & vbCrLf
    Case iFACILITY_UMI:            sErr = sErr & "UMI" & vbCrLf
    Case iFACILITY_URT:            sErr = sErr & "URT" & vbCrLf
    Case iFACILITY_WIN32:          sErr = sErr & "Win32" & vbCrLf
    Case iFACILITY_WINDOWS:        sErr = sErr & "WINDOWS" & vbCrLf
    Case iFACILITY_WINDOWS_CE:     sErr = sErr & "WINDOWS_CE" & vbCrLf
    Case Else:                     sErr = sErr & "Unknown" & vbCrLf
    End Select

' Get error number and description and return
    GetErrorInfo = sErr & "   Number: " & CStr(iNumber) & vbCrLf & _
                          "   Description: " & sDescription

End Function