Option Compare Database

Option Explicit

 

Public Const MyNewFile = "C:\XYZ\XYZ.mdb"

 

Sub RebuildXYZ()

    ' run this to create a new non-replicated Access file,

    '       as: C:\XYZ\XYZ.mdb

    Create_XYZ_new

    Rebuild_Properties

End Sub

 

Sub Create_XYZ_new()

    Dim src As DAO.Database, dst As DAO.Database

    Dim tdf As DAO.TableDef, qdf As DAO.QueryDef

    Dim doc As Document, x As Long, strName As String

    '

    On Error GoTo err_sub

    '

    ' create new db in 2002-2003 format

    Application.SetOption "Default File Format", acFileFormatAccess2002

    '

    Set src = CurrentDb

    Set dst = CreateDatabase(MyNewFile, dbLangGeneral)

    ' Tables

    For Each tdf In src.TableDefs

        If Left(tdf.Name, 4) <> "MSys" Then ' no system objects

            If Len(tdf.Connect) = 0 Then ' no linked tables

                If Right(tdf.Name, 9) <> "_Conflict" Then ' no replication tables

                    MakeOneTable tdf.Name

                End If

            End If

        End If

    Next tdf

    ' Queries

    For Each qdf In src.QueryDefs

        If Left(qdf.Name, 1) <> "~" Then

            DoCmd.CopyObject dst.Name, qdf.Name, acQuery, qdf.Name

        End If

    Next qdf

    ' Forms

    For Each doc In src.Containers("Forms").Documents

        DoCmd.CopyObject dst.Name, doc.Name, acForm, doc.Name

    Next doc

    ' Reports

    For Each doc In src.Containers("Reports").Documents

        DoCmd.CopyObject dst.Name, doc.Name, acReport, doc.Name

    Next doc

    ' Macros

    For x = 0 To CurrentProject.AllMacros.Count - 1

        strName = CurrentProject.AllMacros(x).Name

        DoCmd.CopyObject dst.Name, strName, acMacro, strName

    Next x

    ' Modules

    For x = 0 To CurrentProject.AllModules.Count - 1

        strName = CurrentProject.AllModules(x).Name

        DoCmd.CopyObject dst.Name, strName, acModule, strName

    Next x

    '

exit_sub:

    Set doc = Nothing

    Set tdf = Nothing

    Set src = Nothing

    Set dst = Nothing

    Exit Sub

    '

err_sub:

    Select Case Err.Number

        Case 3204

            MsgBox "Destination database already exists", vbExclamation

        Case Else

            MsgBox Err.Description, vbCritical, "Error # " & Err.Number

    End Select

    Resume exit_sub

    '

End Sub

 

Sub MakeOneTable(TableName As String)

    Dim s As String

    Dim db As DAO.Database, tdf As DAO.TableDef, fld As DAO.Field

    '

    Set db = CurrentDb

    Set tdf = db.TableDefs(TableName)

    For Each fld In tdf.Fields

        Select Case fld.Name

            Case "s_ColLineage", "s_Generation", "s_GUID", "s_Lineage"

            Case Else

                If Left(fld.Name, 4) <> "Gen_" Then

                    If Len(s) > 0 Then s = s & ", "

                    s = s & "[" & fld.Name & "]"

                End If

        End Select

    Next fld

    s = "SELECT " & s & " INTO [" & TableName & "] IN '" & MyNewFile & "' FROM [" & TableName & "];"

    DoCmd.SetWarnings False

    DoCmd.RunSQL s

    DoCmd.SetWarnings True

End Sub

 

Sub Rebuild_Properties()

    Dim db As DAO.Database, prp As DAO.Property

    Set db = OpenDatabase(MyNewFile)

    '

    Set prp = db.CreateProperty("Auto Compact", dbLong, 1)

    db.Properties.Append prp

    Set prp = db.CreateProperty("Track Name AutoCorrect Info", dbLong, 0)

    db.Properties.Append prp

    Set prp = db.CreateProperty("AppTitle", dbText, "XYZ - Application Title for XYZ Database")

    db.Properties.Append prp

    Set prp = db.CreateProperty("StartUpForm", dbText, "Form.My_Main_Menu")

    db.Properties.Append prp

    Set prp = db.CreateProperty("StartUpShowDBWindow", dbBoolean, False)

    db.Properties.Append prp

    Set prp = db.CreateProperty("StartUpShowStatusBar", dbBoolean, True)

    db.Properties.Append prp

    Set prp = db.CreateProperty("AllowShortcutMenus", dbBoolean, True)

    db.Properties.Append prp

    Set prp = db.CreateProperty("AllowFullMenus", dbBoolean, False)

    db.Properties.Append prp

    Set prp = db.CreateProperty("AllowBuiltInToolbars", dbBoolean, False)

    db.Properties.Append prp

    Set prp = db.CreateProperty("AllowToolbarChanges", dbBoolean, False)

    db.Properties.Append prp

    Set prp = db.CreateProperty("AllowSpecialKeys", dbBoolean, False)

    db.Properties.Append prp

    Set prp = db.CreateProperty("AppIcon", dbText, "C:\WINDOWS\Cursors\MyCursor.cur")

    db.Properties.Append prp

    db.Close

    Set prp = Nothing

    Set db = Nothing

End Sub