Here is a quick routine I've used to do just that. It's not as "pretty" as
it ought to be, but it works. This exports data to a new file created on a
floppy (A: drive).
Private Sub cmdExportLeaveInfo_Click()
On Error GoTo CheckError
'For the export to Excel, the needed date is SCD which is
'in the tblBUMs table. The tblBUTime table shouldn't
'be needed. This should work as already modified.
Dim msg As String, wrkDefault As DAO.Workspace, dbsNew As DAO.Database
Dim RetVal As Integer, qdf As DAO.QueryDef
'Check for a floppy in the A: drive then create an mdb
'file on the A: drive
msg = "The tables and queries needed for the primetime leave spreadsheet to
a database file on the A: drive."
msg = msg & vbCrLf & "If there is already a file named D10 Database.mdb it
will be replaced."
msg = msg & vbCrLf & "Insert a blank formatted disk into the A: drive and
click Ok when ready."
RetVal = MsgBox(msg, vbInformation + vbOKCancel, "Insert Floppy")
If RetVal = vbCancel Then Exit Sub
'No need to set these every try, so let's do it now.
Set wrkDefault = DBEngine.Workspaces(0)
TryAgain:
'Check on API calls to see if the drive is ready and insert it here
DoCmd.Hourglass True
If Dir("A:\D10 Database.mdb") <> "" Then Kill "A:\D10 Database.mdb"
Set dbsNew = wrkDefault.CreateDatabase("A:\D10 Database.mdb", _
dbLangGeneral & ";pwd=secret stuff", dbVersion30)
'Export the needed tables and queries
DoCmd.TransferDatabase acExport, "Microsoft Access", "" & dbsNew.Name & "",
acTable, "tblBUMs", "tblBUMs", , True
DoCmd.TransferDatabase acExport, "Microsoft Access", "" & dbsNew.Name & "",
acTable, "tblTeam", "tblTeam", , True
DoCmd.TransferDatabase acExport, "Microsoft Access", "" & dbsNew.Name & "",
acTable, "tblBU", "tblBU", , True
'DoCmd.TransferDatabase acExport, "Microsoft Access", "" & dbsNew.Name & "",
acQuery, "qryPassToExcel", "qryPassToExcel", , True
'Can only export tables to earlier versions of mdb files
'so I have to create the query in the new database.
dbsNew.CreateQueryDef "qryPassToExcel",
CurrentDb.QueryDefs("qryPassToExcel").SQL
CleanUp:
DoCmd.Hourglass False
On Error Resume Next
dbsNew.Close
Set dbsNew = Nothing
Set wrkDefault = Nothing
Exit Sub
CheckError:
DoCmd.Hourglass False
'Error 52 is generated if no floppy is in the drive when doing a Dir
If Err.Number = 52 Then
msg = "Please insert a formatted disk in the A: drive!" & vbCrLf &
"Click Ok when ready."
RetVal = MsgBox(msg, vbCritical + vbOKCancel, "Insert Floppy")
If RetVal = vbCancel Then Resume CleanUp
Resume TryAgain
End If
If Err.Number = 3026 Then
msg = "Disk is full! Please insert a floppy with at least 60k of empty
space."
RetVal = MsgBox(msg, vbCritical + vbOKCancel, "Insert Floppy")
If RetVal = vbCancel Then Resume CleanUp
Resume TryAgain
End If
msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg, vbOKOnly + vbExclamation, "Error", Err.HelpFile, Err.HelpContext
Resume CleanUp