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?
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?
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.Visibl e = 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.OpenCurrentDatab ase 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(intCntOrdin al)
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.DeleteObje ct 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.Visibl e = True
Me!cmdClose.Caption = "Close"
Me!cmdClose.SetFocus
Me!txtWait.Visible = False
appTarget.CloseCurrentData base '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
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.Visibl
Me!cmdExport.Visible = False
Me!cmdClose.Visible = False
Me.Repaint
Set dbs = CurrentDb
Dim appTarget As New Access.Application 'NEEDED FOR Q160875 WORKAROUND
appTarget.OpenCurrentDatab
'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(intCntOrdin
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.DeleteObje
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.Visibl
Me!cmdClose.Caption = "Close"
Me!cmdClose.SetFocus
Me!txtWait.Visible = False
appTarget.CloseCurrentData
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
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.
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
Cheers, Andrew
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.
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
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Cheers, Andrew