Link to home
Start Free TrialLog in
Avatar of noonand
noonand

asked on

Export Database Objects

I need to copy each object of a database into a new database via VBA code.  I'm using code because there is one table, "tblMain", that I only want to copy a subset of its total number of rows.

I can create the new copy and all of its objects correctly; however, I also want the new copy of the database to have the same references as the original.
 
How can I transfer the references to the newly created database?
Avatar of TextReport
TextReport
Flag of United Kingdom of Great Britain and Northern Ireland image

If you are refering to the references in a module then you can create references in a module using the AddFromFile or AddFromGUID you can also loop through your references to examine what references you have in your current database. You may need to put these in a table that you then load in the new database when you open it

Cheers, Andrew
this should do the trick; you'll need to build a form, include two cmd buttons; an export and cancel. then a text box and a few labels for the current code set to work. i'll list the code here but if you want i can send you a copy of the mdb that i wrote and you can just use it as is. it works really well..   it will export all objects not prefixed with a  'zs' to a specified target .mdb

i'd named the exporter form the same as i did 'zsfrmExportObjects'.

good luck,
daniels@asix.com


FORM CODE: 'zsfrmExportObjects'

Option Compare Database
Option Explicit

Private Sub Form_Load()

    'this will represent the .mdb location where you want to export your objects to
     txtFileSpec = "C:\Post_objects.mdb"

End Sub

Private Sub cmdExport_Click()
    'Export all visible, ordinary database objects, except for this form and any Autoexec macro.
   
    'Microsoft KB article q160875 "ACC97: TransferDatabase Causes Page Fault If Object Exits" provides
    'a workaround for an Access 97 bug which was encountered with the original design of this procedure.
    'Lines of code in this procedure which are a result of that workaround are identified in comments
    'as "'NEEDED FOR Q160875 WORKAROUND."
   
    On Error GoTo Err_cmdExport_General

    Dim dbs As Database, cnt As Container, doc As Document
    Dim intCntOrdinal As Integer, intExcludeDoc As Integer
    Dim intDocsType As Integer, intObjType As Integer
    Dim strMsg As String
    Dim strTargetDocName
   
    'Validate file specification provided by user
    If txtFileSpec = "" Then
        MsgBox "Please enter a file specification"
        Exit Sub
    ElseIf Dir(txtFileSpec) = "" Then
        MsgBox "File not found.  Please check your file specification and try again."
        Exit Sub
    End If
   
    'Alert user to processing
    Me!txtWait.Visible = True
    Me!txtWait.SetFocus
    Me!txtFileSpec.Visible = False
    Me!lblEnterFileSpec.Visible = False
    Me!cmdExport.Visible = False
    Me!cmdClose.Visible = False
    Me.Repaint

    Set dbs = CurrentDb
   
    Dim appTarget As New Access.Application     'NEEDED FOR Q160875 WORKAROUND
    appTarget.OpenCurrentDatabase txtFileSpec   'NEEDED FOR Q160875 WORKAROUND

    'If possible (i.e., not in runtime environment), display Debug window to show audit of export process
    If Not SysCmd(acSysCmdRuntime) Then
        DoCmd.RunCommand acCmdDebugWindow
    End If
           
    For intCntOrdinal = 0 To dbs.Containers.Count - 1   'retained older construct because counter value is used below
        Set cnt = dbs.Containers(intCntOrdinal)
        Debug.Print "Container: " & cnt.name

        'Translate the Container's ordinal into a Documents type
        intDocsType = Choose(intCntOrdinal + 1, -1, acForm, acModule, -1, acReport, acMacro, -1, acTable)
        '(Container names, in order: Databases, Forms, Modules, Relationships, Reports, Scripts, SysRel, Tables)
        'Null wouldn't work, so used -1 is used to identify Document types which shouldn't be exported
       
        If intDocsType > -1 Then     'only process those containers which are appropriate for export
            For Each doc In cnt.Documents
                'Allow for handling a new Autoexec macro or an MSys hidden table
                strTargetDocName = doc.name
                If strTargetDocName = "Autoexec1" Then
                    strTargetDocName = "Autoexec"
                ElseIf Left(strTargetDocName, 5) = "_MSys" Then
                    strTargetDocName = Right(strTargetDocName, Len(strTargetDocName) - 1)
                End If
               
                On Error GoTo Err_cmdExport_Specific    'redirect error handling now that we have a container and document to record if necessary.
                Debug.Print , "Document: " & doc.name,
               
                'Determine whether the current Document should be excluded from the export process
                intExcludeDoc = (doc.name = "Autoexec")                             'exclude autoexec macro that auto-opened this form
                intExcludeDoc = intExcludeDoc Or (doc.name = Me.name)               'exclude this form
                intExcludeDoc = intExcludeDoc Or (doc.name = "zstblTargetFile")     'exclude the table that holds the target file spec
                intExcludeDoc = intExcludeDoc Or (Left(doc.name, 4) = "MSys")       'exclude system objects
               
                If intExcludeDoc Then
                    Debug.Print "(excluded)"
                Else
                    If (intDocsType = acTable) And IsQueryName(doc.name) Then
                        'Query Documents are stored in the Tables Container.  If exported with the acTable objecttype,
                        'they get converted to a table in the receiving database, so it is necessary to distinguish them
                        'from tables and export them with an objecttype of acQuery.
                        intObjType = acQuery
                    Else
                        intObjType = intDocsType
                    End If
                   
                    On Error Resume Next    'ignore the error that Access will generate if it can't find a predecessor object to delete
                    appTarget.DoCmd.DeleteObject intObjType, doc.name       'NEEDED FOR Q160875 WORKAROUND
                    On Error GoTo Err_cmdExport_Specific    'restore normal error handling
                   
                    'DoCmd.TransferDatabase acExport, "Microsoft Access", txtFileSpec, intObjType, doc.name, doc.name
                    DoCmd.TransferDatabase acExport, "Microsoft Access", txtFileSpec, intObjType, doc.name, strTargetDocName
                   
                    Debug.Print "Exported!"
                End If
                DoEvents
            Next doc
        End If
    Next intCntOrdinal
   
    On Error GoTo Err_cmdExport_General     'redirect error handling now that the DAO processing is done
    MsgBox "The export was completed successfully.", vbInformation, "Update Succeeded"

Exit_cmdExport:
    'regardless of error, continue here to finish up presentation of form's controls and close down other app instance
    Me!cmdExport.Visible = True
    Me!cmdClose.Visible = True
    Me!txtFileSpec.Visible = True
    Me!lblEnterFileSpec.Visible = True
    Me!cmdClose.Caption = "Close"
    Me!cmdClose.SetFocus
    Me!txtWait.Visible = False
   
    appTarget.CloseCurrentDatabase      'NEEDED FOR Q160875 WORKAROUND
    Set appTarget = Nothing             'NEEDED FOR Q160875 WORKAROUND
   
    Exit Sub

Err_cmdExport_General:
    strMsg = "The export process failed before document identification.  Please report this message."
    MsgBox strMsg, vbCritical, "Update Failed"
    On Error Resume Next    'let each statement in exit routine attempt execution, regardless
    Resume Exit_cmdExport

Err_cmdExport_Specific:
    strMsg = "The export process failed on Container: " & cnt.name & ", Document: " & doc.name
    strMsg = strMsg & ".  Please report this message."
    MsgBox strMsg, vbCritical, "Update Failed"
    On Error Resume Next    'let each statement in exit routine attempt execution, regardless
    Resume Exit_cmdExport
   
End Sub

Private Sub cmdClose_Click()
   
    DoCmd.Close

End Sub

Private Function IsQueryName(ByVal strObjName As String) As Integer
'Purpose:   Determine if an object name matches a query name
'Usage:     Can differentiate between queries and tables in the Tables container

    On Error GoTo Err_IsQueryName

    Dim dbs As Database
    Dim qdf As QueryDef

    Set dbs = CurrentDb
   
    Set qdf = dbs.QueryDefs(strObjName)   'generates an error if the name doesn't match a query name
    IsQueryName = True   'no error was generated, so it is a query

Exit_IsQueryName:
    Exit Function

Err_IsQueryName:
    IsQueryName = False   'qdf couldn't be set, so object is not a query
    On Error GoTo 0
    Resume Exit_IsQueryName

End Function




Avatar of noonand
noonand

ASKER

Andrew,

If I use AddFromFile and the Reference.FullPath property, do I run the risk of the path not being the same on a different PC.

Affraid So, not sure about GUID though.

Cheers, Andrew
Avatar of noonand

ASKER

I have decided that neither of the aforementioned comments will work well for me.  Instead of trying to copy the references, I have decided to try and get rid of them all together by using late binding instead of early binding.

This solution of mine worked very well and I think saved myself a lot of time.

Thank you for your posts.

No comment has been added lately, so it's time to clean up this TA.
I will leave a recommendation in the Cleanup topic area that this question is:
 - PAQ'd and pts refunded
Please leave any comments here within the
next seven days.

PLEASE DO NOT ACCEPT THIS COMMENT AS AN ANSWER !

Nic;o)
ASKER CERTIFIED SOLUTION
Avatar of Netminder
Netminder

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial