De-replicating a database
This piece of code will copy all objects out of your current
replica database into a database you specify in the exportbdbs string,
recreating tables as it goes on
and not copying the replica id fields. This code is placed in a
module of the replica database you want to export from. Run it from there. It will
not affect your replica database.
Now supports Export Queries, Export Forms, Export
Reports, Export Modules , Export Macros and Recreate Relationships.
Option Compare Database
Option Explicit
'Export Tables Module Sub
'Code to export all the tables from a replica into a new database
'without the replica definitions
'Written by John Hawkins
Private Sub Export_Tables()
Dim Dbs As Database
Dim Tableon As TableDef
Dim Sqlstr As String
Dim FdfField As Fields
Dim Fieldname As Field
Dim QueryOn As QueryDef
Dim Ret As Integer
Dim ExportDbs As String
Dim FormOn As Document
Dim ReportOn As Document
Dim ModuleOn As Document
Dim MacroOn As Document
Dim Relationship As Relation
Dim Relnew As Relation
Dim RelField As Field
Dim ExpDbs As Database
Dim X As Integer
Dim Idx As Index
Dim IdxNew As Index
Dim Idxfield As Field
Dim PropField As Property
ExportDbs = "c:\eid\db1.mdb"
Set Dbs = CurrentDb
Set ExpDbs = OpenDatabase(ExportDbs)
'Export Tables
Ret = MsgBox("Do you want to export all table to
database " & ExportDbs & "?", vbYesNo)
If Ret = vbYes Then
For Each Relationship In
ExpDbs.Relations
ExpDbs.Relations.Delete Relationship.Name
Next
For Each Tableon In Dbs.TableDefs
Sqlstr =
"SELECT "
If Left$(Tableon.Name,
4) <> "Msys" Then
Set FdfField = Tableon.Fields
For Each Fieldname In FdfField
If Left$(Fieldname.Name, 2) <> "s_" Then
Sqlstr = Sqlstr & " [" & Tableon.Name & "].["
& Fieldname.Name & "],"
End If
Next
'strip off the last comma
Sqlstr = Left$(Sqlstr, Len(Sqlstr) - 1)
Sqlstr = Sqlstr & " INTO [" & Tableon.Name & "] IN
'" & ExportDbs & "' FROM [" & Tableon.Name &
"];"
DoCmd.SetWarnings False
DoCmd.RunSQL Sqlstr
DoCmd.SetWarnings True
'recreate the indexes
ExpDbs.TableDefs.Refresh
For Each Idx In Tableon.Indexes
If Left$(Idx.Name, 2) <> "s_" Then
'create index and properties for
Set IdxNew = ExpDbs.TableDefs(Tableon.Name).CreateIndex(Idx.Name)
IdxNew.Unique = Idx.Unique
IdxNew.Required = Idx.Required
IdxNew.IgnoreNulls = Idx.IgnoreNulls
IdxNew.Primary = Idx.Primary
IdxNew.Name = Idx.Name
'recreate fields in indexes
For Each Idxfield In Idx.Fields
IdxNew.Fields.Append IdxNew.CreateField(Idxfield.Name)
Next
ExpDbs.TableDefs(Tableon.Name).Indexes.Append IdxNew
End If
Next
End If
Next
End If
'Export Queries
Ret = MsgBox("Do you want to export all queries to
database " & ExportDbs & "?", vbYesNo)
If Ret = vbYes Then
For Each QueryOn In Dbs.QueryDefs
DoCmd.CopyObject ExportDbs, QueryOn.Name, acQuery, QueryOn.Name
Next
End If
'Export Forms
Ret = MsgBox("Do you want to export all forms to
database " & ExportDbs & "?", vbYesNo)
If Ret = vbYes Then
For Each FormOn In
Dbs.Containers!Forms.Documents
DoCmd.CopyObject ExportDbs, FormOn.Name, acForm, FormOn.Name
Next
End If
'Export Reports
Ret = MsgBox("Do you want to export all reports to
database " & ExportDbs & "?", vbYesNo)
If Ret = vbYes Then
For Each ReportOn In
Dbs.Containers!Reports.Documents
DoCmd.CopyObject ExportDbs, ReportOn.Name, acReport, ReportOn.Name
Next
End If
'Export Modules
Ret = MsgBox("Do you want to export all Modules to
database " & ExportDbs & "?", vbYesNo)
If Ret = vbYes Then
For Each ModuleOn In
Dbs.Containers!Modules.Documents
DoCmd.CopyObject ExportDbs, ModuleOn.Name, acModule, ModuleOn.Name
Next
End If
'Export Macros
Ret = MsgBox("Do you want to export all Macros to
database " & ExportDbs & "?", vbYesNo)
If Ret = vbYes Then
For Each MacroOn In
Dbs.Containers!Scripts.Documents
DoCmd.CopyObject ExportDbs, MacroOn.Name, acMacro, MacroOn.Name
Next
End If
'Export Relationships
Ret = MsgBox("Do you want to recreate Relationships to
database " & ExportDbs & "? This will delete all current
relationships.", vbYesNo)
If Ret = vbYes Then
ExpDbs.Relations.Refresh
For Each Relationship In
ExpDbs.Relations
ExpDbs.Relations.Delete Relationship.Name
Next
Dbs.Relations.Refresh
ExpDbs.Relations.Refresh
For Each Relationship In
Dbs.Relations
Set Relnew =
ExpDbs.CreateRelation(Relationship.Name & Int(Rnd(1) * 100),
Relationship.Table, Relationship.ForeignTable, Relationship.Attributes)
X = 0
For Each RelField In Relationship.Fields
Relnew.Fields.Append Relnew.CreateField(RelField.Name)
Relnew.Fields(X).ForeignName = RelField.ForeignName
X = X + 1
Next
ExpDbs.Relations.Append Relnew
Next
End If
ExpDbs.Close
DBEngine.CompactDatabase ExportDbs, "c:\temp.mdb"
Kill ExportDbs
FileCopy "c:\temp.mdb", ExportDbs
Kill "c:\temp.mdb"
End Sub
|
|