505.369.1650 [email protected]

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:

  1. 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.
  2. 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.
  3. 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.
  4. Run the UnReplicate() function.
  5. When the first browser box appears, select the replicated database.  When the second browser box appears, select the new database.
  6. 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.
  7. 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.
  8. 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.1
' Copyright © 2013 Extra Mile Data, www.extramiledata.com.
' For questions or issues, please contact [email protected].
' 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 Left(tblRep.Name, 4) <> "MSys" 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