Public Sub ConstructionExtract()
'exports data to ConstructionExtract Access file
'copies file to zip folder
'opens Outlook and attaches file to msg and sends
Dim strZip As String
Dim strExtract As String
strZip = gstrBasePath & "Editing\ConstructionExtract.zip"
strExtract = gstrBasePath & "Editing\ConstructionExtract.accdb"
'delete records from ConstructionExtract tables
CurrentDb.Execute "DELETE FROM Bituminous IN '" & strExtract & "'"
CurrentDb.Execute "DELETE FROM BituminousMD IN '" & strExtract & "'"
CurrentDb.Execute "DELETE FROM Concrete IN '" & strExtract & "'"
CurrentDb.Execute "DELETE FROM Emulsion IN '" & strExtract & "'"
CurrentDb.Execute "DELETE FROM PGAsphalt IN '" & strExtract & "'"
CurrentDb.Execute "DELETE FROM SoilsAgg IN '" & strExtract & "'"
CurrentDb.Execute "DELETE FROM SampleInfo IN '" & strExtract & "'"
'insert records into ConstructionExtract tables
CurrentDb.Execute "INSERT INTO Bituminous IN '" & strExtract & "' SELECT * FROM ConstructionBIT;"
CurrentDb.Execute "INSERT INTO BituminousMD IN '" & strExtract & "' SELECT * FROM ConstructionBMD;"
CurrentDb.Execute "INSERT INTO Concrete IN '" & strExtract & "' SELECT * FROM ConstructionCONC;"
CurrentDb.Execute "INSERT INTO Emulsion IN '" & strExtract & "' SELECT * FROM ConstructionEMUL;"
CurrentDb.Execute "INSERT INTO PGAsphalt IN '" & strExtract & "' SELECT * FROM ConstructionPG;"
CurrentDb.Execute "INSERT INTO SoilsAgg IN '" & strExtract & "' SELECT * FROM ConstructionSA;"
CurrentDb.Execute "INSERT INTO SampleInfo IN '" & strExtract & "' SELECT * FROM ConstructionSampleInfo;"
'create empty zip folder
'found this on web, no idea what the Print line does but if it isn't there, this won't work
Open strZip For Output As #1
Print #1, "PK" & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'copy file into zip folder
Dim objApp As Object
Set objApp = CreateObject("Shell.Application")
'variable for source file doesn't seem to work in this line
'also double parens not in original example code but won't work without
objApp.NameSpace((strZip)).CopyHere gstrBasePath & "Editing\ConstructionExtract.accdb"
'open Outlook, attach zip folder, send e-mail
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.BodyFormat = olFormatRichText
.To = "june7ak@live.com"
''.cc = ""
''.bcc = ""
.Subject = "Central Materials Laboratory Data"
.HTMLBody = "Construction data extract: " & Now
.Attachments.add (strZip)
.DeleteAfterSubmit = True 'to not retain in sent folder
.Display
''.Send
End With
'delete zip folder
Kill strZip
CurrentDb.Execute "UPDATE Updates SET ConstructionExtract=#" & Date & "#"
End Sub
