This VBA function copies or imports all the objects and database startup properties from a Microsoft Access replicated database into an un-replicated database. It removes tablename_Conflict tables and removes replication-related fields like s_GUID, etc.
Background:
The Microsoft support site describes some methods that can be used change a replicated MS Access database to a normal database:
Access 95, Access 97 wizards and manual method description -
http://support.microsoft.com/kb/q153526/
Access 2000 - Access 2003 manual method -
http://support.microsoft.com/kb/290052/
Not only do the tables need to recreated, but there is a list of other items to restore:
- Non-default references (in code)
- Security of the database objects
- Table indexes and relationships
- Table properties
- Validation rules
- Database properties (like the startup options)
- Forms, Reports, Modules, Macros, and Pages
Other than the non-default references, database object security, and the import of Pages, the code below automatically takes care of the whole list.
How to use:
- Create a blank new database. In my version of Windows, I just did a right-click in the folder, selected the New option, then Microsoft Office Access Database. As soon as the file appears, name it something useful.
- The code is meant to run in a database separate from the replicated or new database. Import the code module (which you can download below) or create a new code module and copy the code into it.
- In the database with the code module, use the Tools, References menu option to set some references. The FileDialog object requires a reference to a Microsoft Office Object Library (10 [Access 2002] or later). And because the code uses DOA, it requires a reference to Microsoft DAO Object Library, or for Access 2007 and later, the Microsoft Office Access database engine Object Library.
- Run the UnReplicate() function.
- When the first browser box appears, select the replicated database. When the second browser box appears, select the new database.
- The hourglass will appear, and depending upon how much data is in your tables and the speed of your processor, it may take several minutes before the "UnReplicate is complete" message appears.
- If the new database has any code modules, set non-default dll references by using the Tools, References menu option. When you get them all properly selected, you should be able to compile without an error.
- If you need to establish database object security, finish the job with that.
Notes about the code:
- The code works best when it is called from a database separate from the replicated and new databases. This is because the TransferDatabase actions that are used to import the Forms, Reports, etc., require the new database to be opened exclusively. That is also why the dbNew database is closed before the TransferDatabase actions are called using the appNew object.
- Because of the reference to the Microsoft Office Object Library, the file picker part of the code will only work if Access 2002 or later is installed. You can replace this with some common dialog code for versions before that.
- The database properties that are copied over relate to a select list of startup options. You can find the list where the avarSUOpt array is created. Feel free to add or subtract from the list.
- If you need to import Pages as well, add a section similar to the Import Macros section and use the “Pages” container.
Code:
Option Compare Database
Option Explicit
Public Function UnReplicate() As Boolean
' This function copies or imports all the objects and database startup
' properties from a replicated database into an un-replicated database.
' It removes tablename_Conflict tables and removes replication-related
' fields like s_GUID, etc.
' UnReplicate() Version 1.1.0
' Copyright © 2009 Extra Mile Data, www.extramiledata.com.
' For questions or issues, please contact support@extramiledata.com.
' Use (at your own risk) and modify freely as long as proper credit is given.
' The core logic for the table and query copy was modified from:
' http://www.gab2001uk.com/visualbasic/daovsado/daocopy.htm
On Error GoTo Err_UnReplicate
' FileDialog requires a reference to a Microsoft Office Object Library
' (10 [Access 2002] or later).
Dim fdlPick As Office.FileDialog
Dim varFileRep
Dim varFileNew
' DOA requires a reference to Microsoft DAO Object Library, or for
' Access 2007 and later, the Microsoft Office Access database engine
' Object Library.
' Database.
Dim dbRep As DAO.Database
Dim dbNew As DAO.Database
' For copying tables and indexes.
Dim tblRep As DAO.TableDef
Dim tblNew As DAO.TableDef
Dim fldRep As DAO.Field
Dim fldNew As DAO.Field
Dim idxRep As DAO.Index
Dim idxNew As DAO.Index
' For copying data.
Dim rstRep As DAO.Recordset
Dim rstNew As DAO.Recordset
Dim intC As Integer
' For copying table relationships.
Dim relRep As DAO.Relation
Dim relNew As DAO.Relation
' For copying queries.
Dim qryRep As DAO.QueryDef
Dim qryNew As DAO.QueryDef
' For copying startup options.
Dim avarSUOpt
Dim strSUOpt As String
Dim varValue
Dim varType
Dim prpRep As DAO.Property
Dim prpNew As DAO.Property
' For importing forms, reports, modules, and macros.
Dim appNew As New Access.Application
Dim doc As DAO.Document
' Get a file dialog and ask the user for the replicated database.
' If they cancel, then exit.
Set fdlPick = Application.FileDialog(msoFileDialogFilePicker)
With fdlPick
.AllowMultiSelect = False
.Title = "Select the replicated database"
.Filters.Clear
.Filters.Add "Access Databases", "*.MDB"
If .Show = True Then
varFileRep = .SelectedItems(1)
Else
GoTo Exit_UnReplicate
End If
End With ' fdlPick
' Open the replicated database, not in exclusive mode.
Set dbRep = OpenDatabase(varFileRep, False)
' Get a file dialog and ask the user for the replicated database.
' If they cancel, then exit.
Set fdlPick = Nothing
Set fdlPick = Application.FileDialog(msoFileDialogFilePicker)
With fdlPick
.AllowMultiSelect = False
.Title = "Select the new un-replicated database"
.Filters.Clear
.Filters.Add "Access Databases", "*.MDB"
.Filters.Add "Access Databases", "*.ACCDB"
If .Show = True Then
varFileNew = .SelectedItems(1)
Else
GoTo Exit_UnReplicate
End If
End With ' fdlPick
' Open the new database, in exclusive mode.
Set dbNew = OpenDatabase(varFileNew, True)
DoEvents
' Turn on the hourglass.
DoCmd.Hourglass True
'********************
Debug.Print "Copy Tables"
'********************
' Loop through the collection of table definitions.
For Each tblRep In dbRep.TableDefs
' Ignore system tables and _Confict tables.
If InStr(1, tblRep.Name, "MSys", vbTextCompare) = 0 And _
InStr(1, tblRep.Name, "_Conflict", vbTextCompare) = 0 Then
'***** Table definition
' Create a table definition with the same name.
Set tblNew = dbNew.CreateTableDef(tblRep.Name)
' Set properties.
tblNew.ValidationRule = tblRep.ValidationRule
tblNew.ValidationText = tblRep.ValidationText
' Loop through the collection of fields in the table.
For Each fldRep In tblRep.Fields
' Ignore replication-related fields:
' Gen_XXX, s_ColLineage, s_Generation, s_GUID, s_Lineage
If Left(fldRep.Name, 2) <> "s_" And _
Left(fldRep.Name, 4)<> "Gen_" Then
'***** Field definition
Set fldNew = tblNew.CreateField(fldRep.Name, fldRep.Type, _
fldRep.Size)
' Set properties.
On Error Resume Next
fldNew.Attributes = fldRep.Attributes
fldNew.AllowZeroLength = fldRep.AllowZeroLength
fldNew.DefaultValue = fldRep.DefaultValue
fldNew.Required = fldRep.Required
fldNew.Size = fldRep.Size
' Append the field.
tblNew.Fields.Append fldNew
On Error GoTo Err_UnReplicate
End If
Next fldRep
'***** Index definition
' Loop through the collection of indexes.
For Each idxRep In tblRep.Indexes
' Ignore replication-related indexes:
' s_Generation, s_GUID
If Left(idxRep.Name, 2) <> "s_" Then
' Ignore indices set as part of Relation Objects
If Not idxRep.Foreign Then
' Create an index with the same name.
Set idxNew = tblNew.CreateIndex(idxRep.Name)
' Set properties.
idxNew.Clustered = idxRep.Clustered
idxNew.IgnoreNulls = idxRep.IgnoreNulls
idxNew.Primary = idxRep.Primary
idxNew.Required = idxRep.Required
idxNew.Unique = idxRep.Unique
' Loop through the collection of index fields.
For Each fldRep In idxRep.Fields
' Create an index field with the same name.
Set fldNew = idxNew.CreateField(fldRep.Name)
' Set properties.
fldNew.Attributes = fldRep.Attributes
' Append the index field.
idxNew.Fields.Append fldNew
Next fldRep
' Append the index to the table.
tblNew.Indexes.Append idxNew
End If
End If
Next idxRep
' Append the table.
dbNew.TableDefs.Append tblNew
End If
Next tblRep
'********************
Debug.Print "Copy Data"
'********************
' Loop through the list of table definitions.
For Each tblRep In dbRep.TableDefs
' Ignore system tables and _Confict tables.
If Left(tblRep.Name, 4) <> "MSys" And _
InStr(1, tblRep.Name, "_Conflict", vbTextCompare) = 0 Then
' Open a recordset for the un-replicated table.
Set rstNew = dbNew.OpenRecordset(tblRep.Name, dbOpenTable)
' Open a recordset for the replicated table.
Set rstRep = dbRep.OpenRecordset(tblRep.Name, dbOpenTable)
' Continue if there are records.
If Not rstRep.BOF Then
' Move to the first record.
rstRep.MoveFirst
' Loop through all the replicated table records.
Do Until rstRep.EOF
' Add a record to the un-replicated table.
rstNew.AddNew
' For each field in the un-replicated table, set the value
' to the value in the related field of the replicated table.
For intC = 0 To rstNew.Fields.Count - 1
rstNew.Fields(intC).Value = _
rstRep.Fields(rstNew.Fields(intC).Name).Value
Next
' Update the un-replicated table.
rstNew.Update
' Move to the next replicated table record.
rstRep.MoveNext
Loop ' rstRep
End If
' Close the un-replicated recordset.
rstNew.Close
' Close the replicated recordset.
rstRep.Close
End If
Next tblRep
'********************
Debug.Print "Copy Relationships"
'********************
' Loop through the collection of table relationships.
For Each relRep In dbRep.Relations
' Create a relation with the same name.
Set relNew = dbNew.CreateRelation(relRep.Name, relRep.Table, _
relRep.ForeignTable, relRep.Attributes)
' Loop through the collection of relation fields.
For Each fldRep In relRep.Fields
' Append a relation field with the same name.
relNew.Fields.Append relNew.CreateField(fldRep.Name)
' Give the relation field the same foreign name.
relNew.Fields(fldRep.Name).ForeignName = _
relRep.Fields(fldRep.Name).ForeignName
Next fldRep
' Append the the relation to the database.
dbNew.Relations.Append relNew
Next relRep
'********************
Debug.Print "Copy Queries"
'********************
' Loop through the collection of query definitions.
' We use this method rather than TransferDatabase action used below
' because both tables and queries are listed in the Tables container.
For Each qryRep In dbRep.QueryDefs
' Create a query definition with the same name and SQL.
Set qryNew = dbNew.CreateQueryDef(qryRep.Name, qryRep.SQL)
' Set properties.
qryNew.Connect = qryRep.Connect
qryNew.MaxRecords = qryRep.MaxRecords
qryNew.ReturnsRecords = qryRep.ReturnsRecords
' Append the query definition to the database (NOT NECESSARY).
' dbRep.QueryDefs.Append qryNew
Next qryRep
'********************
Debug.Print "Copy Startup Options"
'********************
' Create an array of startup options to examine.
avarSUOpt = Array( _
"AllowBreakIntoCode", _
"AllowBuiltInToolbars", _
"AllowFullMenus", _
"AllowShortcutMenus", _
"AllowSpecialKeys", _
"AllowToolbarChanges", _
"AppIcon", _
"AppTitle", _
"StartupForm", _
"StartupMenuBar", _
"StartupShortcutMenuBar", _
"StartupShowDBWindow", _
"StartupShowStatusBar")
' Handle errors in this section of code.
On Error Resume Next
' Loop through the array.
For intC = 0 To UBound(avarSUOpt)
' Get the name of the property from the array.
strSUOpt = avarSUOpt(intC)
' Clear and continue if there is an error.
Err.Clear
' Try to get the property in the replicated database.
Set prpRep = dbRep.Properties(strSUOpt)
If Err.Number = 0 Then
' The property exists in the replicated database.
' Get its Value and Type.
varValue = prpRep.Value
varType = prpRep.Type
' Try to get the property in the un-replicated database.
Set prpNew = dbNew.Properties(strSUOpt)
If Err.Number = 0 Then
' The property exists. Reset its value to the
' replicated database value.
prpNew.Value = varValue
Else
' The property does not exist yet. Create the property,
' using the replicated database type and value, and
' then append it to the database.
Set prpNew = dbNew.CreateProperty(strSUOpt, varType, varValue)
dbNew.Properties.Append prpNew
End If
Else
' The property does not exist in the replicated
' database, so ignore it.
End If
Next intC
' Turn overall error handling back on.
On Error GoTo Err_UnReplicate
' Close the un-replicated database so that it can be opened
' exclusively using GetObject.
dbNew.Close
' Get the Access application object for the un-replicated database.
Set appNew = GetObject(varFileNew)
appNew.Visible = False
'********************
Debug.Print "Import Forms"
'********************
' Loop through the collection of forms in the replicated database
' and import each one. This automatically removes the replicated flag.
For Each doc In dbRep.Containers("Forms").Documents
appNew.DoCmd.TransferDatabase acImport, "Microsoft Access", _
varFileRep, acForm, doc.Name, doc.Name
Next doc
'********************
Debug.Print "Import Reports"
'********************
' Loop through the collection of reports in the replicated database
' and import each one. This automatically removes the replicated flag.
For Each doc In dbRep.Containers("Reports").Documents
appNew.DoCmd.TransferDatabase acImport, "Microsoft Access", _
varFileRep, acReport, doc.Name, doc.Name
Next doc
'********************
Debug.Print "Import Modules"
'********************
' Loop through the collection of modules in the replicated database
' and import each one. This automatically removes the replicated flag.
For Each doc In dbRep.Containers("Modules").Documents
appNew.DoCmd.TransferDatabase acImport, "Microsoft Access", _
varFileRep, acModule, doc.Name, doc.Name
Next doc
'********************
Debug.Print "Import Macros"
'********************
' Loop through the collection of macros in the replicated database
' and import each one. This automatically removes the replicated flag.
For Each doc In dbRep.Containers("Scripts").Documents
appNew.DoCmd.TransferDatabase acImport, "Microsoft Access", _
varFileRep, acMacro, doc.Name, doc.Name
Next doc
' Close the un-replicated database.
appNew.Quit
' Message the user.
MsgBox "UnReplicate is complete."
Debug.Print "Complete"
UnReplicate = True
Exit_UnReplicate:
On Error Resume Next
' Turn off the hourglass.
DoCmd.Hourglass False
' Clean up.
Set fdlPick = Nothing
Set idxRep = Nothing
Set idxNew = Nothing
Set fldRep = Nothing
Set fldNew = Nothing
Set tblRep = Nothing
Set tblNew = Nothing
rstRep.Close
rstNew.Close
Set rstRep = Nothing
Set rstNew = Nothing
Set relRep = Nothing
Set relNew = Nothing
Set qryRep = Nothing
Set qryNew = Nothing
Set prpRep = Nothing
Set prpNew = Nothing
dbRep.Close
dbNew.Close
Set dbRep = Nothing
Set dbNew = Nothing
Set doc = Nothing
appNew.Quit
Set appNew = Nothing
Exit Function
Err_UnReplicate:
MsgBox Err.Number & " " & Err.Description, vbCritical, "UnReplicate()"
UnReplicate = False
Resume Exit_UnReplicate:
End Function
Download Code: basUnReplicate.zip