I figured it out, the routine I was using works weather or not a record is
being edited, believe me I tested it 15 times.
It just dont get the very latest changes or an added record. NO crashs.
Here it is for the benifit of others. I have certain folders I use of
course. Note this is opposite of inport I saw on the web. There's a form I
have with a command
button that calls this function, has to be done this way, from swithchboard
alone won't work.
Option Compare Database
Option Explicit
Public Function EXPORTDB()
On Error Resume Next
CSB
Dim wrkDefault As Workspace
Dim DB As Database
Set wrkDefault = DBEngine.Workspaces(0)
Set DB = wrkDefault.CreateDatabase("C:\HP\CONTACT.MDB", dbLangGeneral) '
just a blank folder
DB.Close
Set DB = Nothing
'Dim db As Database 'Database to import
Dim td As TableDef 'Tabledefs in db
Dim strTDef As String 'Name of table or query to import
Dim qd As QueryDef 'Querydefs in db
Dim doc As Document 'Documents in db
Dim strCntName As String 'Document container name
Dim X As Integer 'For looping
Dim cntContainer As Container 'Containers in db
Dim strDocName As String 'Name of document
Dim intConst As Integer
Dim cdb As Database 'Current Database
Dim rel As Relation 'Relation to copy
Dim nrel As Relation 'Relation to create
Dim strRName As String 'Copied relation's name
Dim strTName As String 'Relation Table name
Dim strFTName As String 'Relation Foreign Table name
Dim varAtt As Variant 'Attributes of relation
Dim fld As Field 'Field(s) in relation to copy
Dim strFName As String 'Name of field to append
Dim strFFName As String 'Foreign name of field to append
'Open database which contains objects to EXPORT
Set cdb = CurrentDb
'EXPORT tables from specified Access database
For Each td In cdb.TableDefs
strTDef = td.NAME
If Left(strTDef, 4) <> "MSys" Then
DoCmd.TransferDatabase acExport, "Microsoft Access", "C:\HP\CONTACT.MDB",
acTable, strTDef, strTDef, False
End If
Next
'Import queries
For Each qd In cdb.QueryDefs
strTDef = qd.NAME
DoCmd.TransferDatabase acExport, "Microsoft Access", "C:\HP\CONTACT.MDB",
acQuery, strTDef, strTDef, False
Next
'Copy relationships to OUTPUT database
Set DB = DBEngine.Workspaces(0).OpenDatabase("C:\HP\CONTACT.MDB")
For Each rel In cdb.Relations
With rel
'Get properties of relation to copy
strRName = .NAME
strTName = .Table
strFTName = .ForeignTable
varAtt = .Attributes
'Create relation in EXPORT db with same properties
Set nrel = DB.CreateRelation(strRName, strTName, strFTName, varAtt)
For Each fld In .Fields
strFName = fld.NAME
strFFName = fld.ForeignName
nrel.Fields.Append nrel.CreateField(strFName)
nrel.Fields(strFName).ForeignName = strFFName
Next
DB.Relations.Append nrel
End With
Next
DB.Close
'Loop through containers and import all documents
For X = 1 To 4
Select Case X
Case 1
strCntName = "Forms"
intConst = acForm
Case 2
strCntName = "Reports"
intConst = acReport
Case 3
strCntName = "Scripts"
intConst = acMacro
Case 4
strCntName = "Modules"
intConst = acModule
End Select
Set cntContainer = cdb.Containers(strCntName)
For Each doc In cntContainer.Documents
strDocName = doc.NAME
DoCmd.TransferDatabase acExport, "Microsoft Access", "C:\HP\CONTACT.MDB",
intConst, strDocName, strDocName
'Debug.Print strDocName
'for debugging, will list document names in debug window
Next doc
Next X
'Clean up variables to recover memory
cdb.Close
Set fld = Nothing
Set nrel = Nothing
Set rel = Nothing
Set cdb = Nothing
Set td = Nothing
Set qd = Nothing
Set cntContainer = Nothing
Set DB = Nothing
BACKUP
'TRDB
'Call Shell("C:\MYDOCU~1\MDBBACK\DOGBACK.BAT", 1) 'copies it to another
folder for emailing
OSB
'MsgBox "REMOVE DISK FROM DRIVE A / PUT AWAY"
End Function
Function BACKUP()
On Error GoTo Err_cmdOK_Click
Dim strNewDBName As String
Dim strOldDBName As String
Dim strNewDBNCOP As String
Dim KOUNT As Integer
KOUNT = 0
Do
KOUNT = KOUNT + 1
If KOUNT = 1000 Then Exit Do
Loop
KOUNT = 0
strOldDBName = "C:\HP\CONTACT.mdb"
'strNewDBName = "C:\PEDIGREE\PEDBACK\CONTACT.MDB"
'FileCopy strOldDBName, strNewDBName
strNewDBName = "C:\BACKUP\MDBBACK\CONTACT.MDB"
FileCopy strOldDBName, strNewDBName
' repair backup database
'DBEngine.RepairDatabase strNewDBName
'DBEngine.CompactDatabase strNewDBName, strNewDBNCOP
Exit_cmdOK_Click:
MsgBox "BACKED UP TO DIR C:\BACKUP\MDBBACK\CONTACT.MDB"
Kill "C:\HP\CONTACT.mdb"
Exit Function
Err_cmdOK_Click:
MsgBox Str(Err)
MsgBox Error$
Resume Exit_cmdOK_Click
End Function
Function CSB()
DoCmd.Close acForm, "Switchboard", acSaveYes
End Function
Function OSB()
DoCmd.Close acForm, "BACKUP", acSaveYes
DoCmd.OpenForm "Switchboard", acNormal
End Function
