Hi All,
I have been working on an email project where I use a couple of sql queries in access to send an email with an excel attachement. It all works quite will except that the excel attachment comes up blank or closed? I am not sure anyway the worksheet is gone and I am unsure why, any help with this would be very much appreciated
Here is my code that I am using
Option Compare Database
Private Sub Command4_Click()
On Error Resume Next
Dim objOutlook As Object
Dim objEmail As Object
Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
'Dim PER As DAO.Recordset
Dim sMessageBody, strCC
Dim apetext As Variant
Dim abdtext As Variant
Dim objExcel As Object
Dim objworkbook As Object
Dim objSheet As Object
Set MyDb = CurrentDb()
apetext = MyDb.QueryDefs("shea").SQL
apetext = Replace(apetext, "@start_date", "'" & Me.startdate & "'")
apetext = Replace(apetext, "@end_date", "'" & Me.enddate & "'")
MyDb.QueryDefs("shea").SQL = apetext
Set rsEmail = MyDb.OpenRecordset("shea", dbOpenDynaset)
Set objOutlook = CreateObject("Outlook.application")
With rsEmail
.MoveFirst
Do Until rsEmail.EOF
Set objEmail = objOutlook.CreateItem(olMailItem)
sMessageBody = ReturnTemplate("sEmail")
'replace variables
sMessageBody = Replace(sMessageBody, "@FORENAME@", rsEmail!FORENAME)
sMessageBody = Replace(sMessageBody, "@SURNAME@", rsEmail!SURNAME)
sMessageBody = Replace(sMessageBody, "@TIMESTAMP@", Format(Now(), "dddd, d mmmm yyyy at h:nn am/pm"))
abdtext = MyDb.QueryDefs("lscd_master").SQL
abdtext = Replace(abdtext, "@start_date", "'" & Me.startdate & "'")
abdtext = Replace(abdtext, "@end_date", "'" & Me.enddate & "'")
abdtext = Replace(abdtext, "@person_code", rsEmail!person_code)
MyDb.QueryDefs("lscd").SQL = abdtext
Set PER = MyDb.OpenRecordset("lscd", dbOpenSnapshot)
Set objExcel = GetObject("excel.application")
Set objworkbook = GetObject(Application.CurrentProject.Path & "\lsc_template.xlsx")
objworkbook.workbooks.Open
Set objSheet = objworkbook.worksheets("lsc")
objSheet.range("A9").copyfromrecordset PER
objworkbook.saveas Application.CurrentProject.Path & "\attachment\lsc_" & rsEmail!person_code & ".xlsx"
Set objExcel = Nothing
Set objworkbook = Nothing
Set objSheet = Nothing
Set PER = Nothing
With objEmail
If IsNull(rsEmail!she) = False Then
.To = rsEmail!she
.SentOnBehalfOfName = "someone@somewhere.co.uk"
.Attachments.Add Application.CurrentProject.Path & "\attachment\lsc" & rsEmail!person_code & ".xlsx"
.Subject = "Lsc monthly spreadsheet"
.Importance = olImportancehigh
.HTMLbody = sMessageBody
.display
End If
End With
Set objEmail = Nothing
.MoveNext
Loop
End With
MsgBox "All " & rsEmail!Count & " emails sent", vbExclamation + vbOKOnly, ""
Set MyDb = Nothing
Set rsEmail = Nothing
Set objOutlook = Nothing
Set objEmail = Nothing
End Sub
Many Thanks
Diehippy
I have been working on an email project where I use a couple of sql queries in access to send an email with an excel attachement. It all works quite will except that the excel attachment comes up blank or closed? I am not sure anyway the worksheet is gone and I am unsure why, any help with this would be very much appreciated
Here is my code that I am using
Option Compare Database
Private Sub Command4_Click()
On Error Resume Next
Dim objOutlook As Object
Dim objEmail As Object
Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
'Dim PER As DAO.Recordset
Dim sMessageBody, strCC
Dim apetext As Variant
Dim abdtext As Variant
Dim objExcel As Object
Dim objworkbook As Object
Dim objSheet As Object
Set MyDb = CurrentDb()
apetext = MyDb.QueryDefs("shea").SQL
apetext = Replace(apetext, "@start_date", "'" & Me.startdate & "'")
apetext = Replace(apetext, "@end_date", "'" & Me.enddate & "'")
MyDb.QueryDefs("shea").SQL = apetext
Set rsEmail = MyDb.OpenRecordset("shea", dbOpenDynaset)
Set objOutlook = CreateObject("Outlook.application")
With rsEmail
.MoveFirst
Do Until rsEmail.EOF
Set objEmail = objOutlook.CreateItem(olMailItem)
sMessageBody = ReturnTemplate("sEmail")
'replace variables
sMessageBody = Replace(sMessageBody, "@FORENAME@", rsEmail!FORENAME)
sMessageBody = Replace(sMessageBody, "@SURNAME@", rsEmail!SURNAME)
sMessageBody = Replace(sMessageBody, "@TIMESTAMP@", Format(Now(), "dddd, d mmmm yyyy at h:nn am/pm"))
abdtext = MyDb.QueryDefs("lscd_master").SQL
abdtext = Replace(abdtext, "@start_date", "'" & Me.startdate & "'")
abdtext = Replace(abdtext, "@end_date", "'" & Me.enddate & "'")
abdtext = Replace(abdtext, "@person_code", rsEmail!person_code)
MyDb.QueryDefs("lscd").SQL = abdtext
Set PER = MyDb.OpenRecordset("lscd", dbOpenSnapshot)
Set objExcel = GetObject("excel.application")
Set objworkbook = GetObject(Application.CurrentProject.Path & "\lsc_template.xlsx")
objworkbook.workbooks.Open
Set objSheet = objworkbook.worksheets("lsc")
objSheet.range("A9").copyfromrecordset PER
objworkbook.saveas Application.CurrentProject.Path & "\attachment\lsc_" & rsEmail!person_code & ".xlsx"
Set objExcel = Nothing
Set objworkbook = Nothing
Set objSheet = Nothing
Set PER = Nothing
With objEmail
If IsNull(rsEmail!she) = False Then
.To = rsEmail!she
.SentOnBehalfOfName = "someone@somewhere.co.uk"
.Attachments.Add Application.CurrentProject.Path & "\attachment\lsc" & rsEmail!person_code & ".xlsx"
.Subject = "Lsc monthly spreadsheet"
.Importance = olImportancehigh
.HTMLbody = sMessageBody
.display
End If
End With
Set objEmail = Nothing
.MoveNext
Loop
End With
MsgBox "All " & rsEmail!Count & " emails sent", vbExclamation + vbOKOnly, ""
Set MyDb = Nothing
Set rsEmail = Nothing
Set objOutlook = Nothing
Set objEmail = Nothing
End Sub
Many Thanks
Diehippy