Option Compare Database
Option Explicit
Private Const MS_ACCESS As String = "Microsoft Access"
Private Const XPORT_SUCCESS As String = " exported successfully"
Private Const FINAL_CHANCE As String = "Final Chance to Say No"
Public Function ExportAndDeleteCustomerObjects(ByVal sCustNo As String, Optional ByVal sExternalDB As String = "D:\temp\my_data.mdb") As Boolean
'WARNING: Code deletes tables, queries and forms!
'only test on a copy of the database
'returns true if no errors encountered
On Error GoTo Err_ExportAndDeleteCustomerObjects
If Len(sCustNo) > 0 Then
Dim obj As AccessObject
Dim sTable As String, sForm As String, sQuery As String
sTable = ""
sForm = ""
sQuery = ""
For Each obj In Application.CurrentData.AllTables
If Left(obj.Name, Len(sCustNo)) = sCustNo Then
sTable = obj.Name
DoCmd.TransferDatabase acExport, MS_ACCESS, sExternalDB, acTable, sTable, sTable, True
MsgBox sTable & XPORT_SUCCESS, vbInformation
Exit For
End If
Next obj
If sTable = "" Then MsgBox "No appropriate table found!", vbInformation
For Each obj In Application.CurrentData.AllForms
If Left(obj.Name, Len(sCustNo)) = sCustNo Then
sForm = obj.Name
DoCmd.TransferDatabase acExport, MS_ACCESS, sExternalDB, acForm, sForm, sForm, True
MsgBox sForm & XPORT_SUCCESS, vbInformation
Exit For
End If
Next obj
If sForm = "" Then MsgBox "No appropriate form found!", vbInformation
For Each obj In Application.CurrentData.AllQueries
If Left(obj.Name, Len(sCustNo)) = sCustNo Then
sQuery = obj.Name
DoCmd.TransferDatabase acExport, MS_ACCESS, sExternalDB, acQuery, sQuery, sQuery, True
MsgBox sQuery & XPORT_SUCCESS, vbInformation
Exit For
End If
Next obj
If sQuery = "" Then MsgBox "No appropriate query found!", vbInformation
If MsgBox("Access is ready to delete those objects exported." & vbCrLf & "Are you sure you wish to proceed?" & "THIS STEP IS IRREVERSIBLE!", vbYesNo Or vbExclamation, "Permanently Delete Objects") = vbYes Then
If sTable <> "" Then
If MsgBox("Delete " & sTable & "?", vbYesNo, FINAL_CHANCE) = vbYes Then
DoCmd.DeleteObject acTable, sTable
MsgBox sTable & " deleted!", vbInformation
End If
End If
If sForm <> "" Then
If MsgBox("Delete " & sForm & "?", vbYesNo, FINAL_CHANCE) = vbYes Then
DoCmd.DeleteObject acForm, sForm
MsgBox sForm & " deleted!", vbInformation
End If
End If
If sQuery <> "" Then
If MsgBox("Delete " & sQuery & "?", vbYesNo, FINAL_CHANCE) = vbYes Then
DoCmd.DeleteObject acQuery, sQuery
MsgBox sQuery & " deleted!", vbInformation
End If
End If
End If
End If
ExportAndDeleteCustomerObjects = True
Exit Function
Err_ExportAndDeleteCustomerObjects:
MsgBox "Error encountered trying to export" & vbCrLf & "Description given was:" & vbCrLf & Err.Description, vbCritical
ExportAndDeleteCustomerObjects = False
Exit Function
End Function
s) just to keep it running and that would kind of defeat the objective of having an automated archive system (as I'll call it to make it sound sensible, which, as we've repeatedly said, it isn't). Something to bear in mind if you're going to be doing 10 or more exports a week. (Better to just do them manually in the first instance.)
