Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

excel email attachment is blank 2

Status
Not open for further replies.
diehippy

diehippy

Technical User
Jul 4, 2007
46
GB
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
 
Sort by date Sort by votes
objworkbook.saveas Application.CurrentProject.Path & "\attachment\lsc_" & rsEmail!person_code & ".xlsx"

.Attachments.Add Application.CurrentProject.Path & "\attachment\lsc" & rsEmail!person_code & ".xlsx"

Looks like you are creating a file called lsc_personname.xls

and in the subsequent statement you are attaching a file called lscpersonname. xls, you are missing the underbar character ("_") in the statement .Attachments.Add etc
 
Upvote 0 Downvote
Many Thanks vbajock for you fast reply,

I check and this was an error when I transferred over to notepad not an error in the code, but thanks for pointing that out I thought I had missed something but I could not see what.

the file attaches correctly and looks like an excel file even has kb size, but when I check that the data is correct for the correct file there is no workbook in the attachment. It opens like you have closed the sheet in the workbook. I have never seen anything like this

Many Thanks

Diehippy



 
Upvote 0 Downvote
Is the data in the workbook when you check it in Excel?
 
Upvote 0 Downvote
I'd get rid of this:
Set objExcel = GetObject("excel.application")
and this:
objworkbook.workbooks.Open

And just after saveas I'd use this:
objworkbook.Close

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886
 
Upvote 0 Downvote
You should put some code in to check to make sure PER isn't an empty record set:


If PER.bof=true and PER.eof =true then

'I'm passing an empty recordset, do something about it...


else

'go ahead and write the attachment


endif
 
Upvote 0 Downvote
Many Thanks for the advice PHV and VBAJOCK, but I still have the same problem with there being no sheets in the workbook, its like it has somehow closed the workbook before doing the save as. I have looked everywhere and this code is correct, any help will be much appreciated

Many Thanks

Diehippy
 
Upvote 0 Downvote
Did you put the code in to test for an empty recordset?
 
Upvote 0 Downvote
I did put the code in, sorry still get the same answer.
 
Upvote 0 Downvote
diehippy,

Please Paste your current code, including any changes you've made thus far.
Thanks.
 
Upvote 0 Downvote
You are still be very vague and it is hard to help you. Ok, you put the code in. What happened? Does the recordset have data in it?
 
Upvote 0 Downvote
Hi,

Sorry for being vague, I put the code in like this:

If PER.BOF = True And PER.EOF = True Then

MsgBox "No data in recordset"



Else

objSheet.range("A9").copyfromrecordset PER
objworkbook.saveas Application.CurrentProject.Path & "\attachment\learner_status_check_" & rsEmail!person_code & ".xlsx"
objworkbook.Close

End If

and as the recordset has data in it no message came up, it produces for excel file but there are no worksheets in it
but the orginal is still in tack, has it got something to do with some data already being in the spreadsheet?

Sorry I am unsure what other information to give you.

Many Thanks

Diehippy
 
Upvote 0 Downvote
Hi,

Here is the new code


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 objworkbook = GetObject(Application.CurrentProject.Path & "\lsc_template.xlsx")

Set objSheet = objworkbook.worksheets("lsc")


If PER.BOF = True And PER.EOF = True Then

MsgBox "No data in recordset"

Else

objSheet.range("A9").copyfromrecordset PER
objworkbook.saveas Application.CurrentProject.Path & "\attachment\learner_status_check_" &

rsEmail!person_code & ".xlsx"
objworkbook.Close

End If

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
 
Upvote 0 Downvote
Some discrepancy here:
objworkbook.saveas Application.CurrentProject.Path & "\attachment\learner_status_check_" &
rsEmail!person_code & ".xlsx"
vs
.Attachments.Add Application.CurrentProject.Path & "\attachment\lsc_" &
rsEmail!person_code & ".xlsx"

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

Moss100
  • Locked
  • Question
Access send email attachments - problem when null or empty
Replies
7
Views
528
Andrzejek
Andrzejek
M
  • Question
display a calendar with appointments in body of html email with access vba
Replies
1
Views
534
SoftwareRT
SoftwareRT
Viswa.R
  • Locked
  • Question
Dimension import from Autocad to Excel
Replies
0
Views
197
Viswa.R
Viswa.R
FrankMars
  • Locked
  • Question
Exporting Records to Excel 1
Replies
6
Views
289
Andrzejek
Andrzejek
Moss100
  • Locked
  • Question
Vba adding record to table when field is integer
Replies
8
Views
290
Moss100
Moss100

Part and Inventory Search

Sponsor

Back
Top