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