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
