Email Body - Need help please

Using the code below, how would I include a report in the body of the email rather than as an attachment? I also need to know how to alter it to send one email form to only 70 address and then open up a new form with 70 more, until all email addresses are used.

Private Sub cmdEmail_Click()
On Error GoTo Err_Handler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strTo As String, strCC As String, strBCC As String
Dim strSubject As String, strMessage As String
strTo = "recipient@someaddress.com" 'Address to send to (required)
strCC = "recipient@someaddress.com" 'Address to copy to (optional)
strSubject = "This is your Subject Line"
strMessage = "This is your Message Text"
Set db = CurrentDb
Set rs = db.OpenRecordset("qryName", dbOpenSnapshot)
Do Until rs.EOF
With rs
If Not IsNull(rs!Email) Then 'Make sure that an email address exists
strBCC = strBCC & rs!Email & "; "
End If
.MoveNext
End With
Loop
strBCC = Left(strBCC, Len(strBCC) - 2) 'Addresses to Blind copy to
Set db = Nothing
Set rs = Nothing
DoCmd.SendObject , , , strTo, strCC, strBCC, strSubject, strMessage
Exit_Handler:
Exit Sub
Err_Handler:
If Err.Number = 2501 Then 'In case the email was canceled
Resume Exit_Handler
Else
MsgBox Err.Number & " " & Err.Description
Resume Exit_Handler
End If
End Sub

Hi Krisw538

Use the following function and code to get your email addresses limited to 70. I will look into making the body of the email your report when I have time later.

Function GetEmailAddress(rs As Recordset, _
intNumber As Integer, varAddress As Variant) As Boolean
varAddress = rs.GetRows(intNumber)
If intNumber > UBound(varAddress, 2) + 1 And Not rs.EOF Then
GetEmailAddress = False
Else
GetEmailAddress = True
End If
End Function

Code behind your email command button:

Private Sub cmdEmail_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strTo As String, strCC As String, strBCC As String
Dim strSubject As String, strMessage As String
Dim intNumber As Integer, intRecord As Integer
Dim strSQL As String
strSQL = "SELECT Email FROM TableName " & _
"WHERE Email Is Not Null;"
strTo = "recipient@someaddress.com" 'Address to send to (required)
strCC = "recipient@someaddress.com" 'Address to copy to (optional)
strSubject = "This is your Subject Line"
strMessage = "This is your Message Text"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
rs.MoveLast
If rs.RecordCount > 70 Then
intNumber = 70
Else
intNumber = rs.RecordCount
End If
With rs
.MoveFirst
Do Until rs.EOF
If GetEmailAddress(rs, intNumber, varAddress) Then
For intRecord = 0 To UBound(varAddress, 2)
strBCC = strBCC & varAddress(0, intRecord) & "; "
Next intRecord
strBCC = Left(strBCC, Len(strBCC) - 2) 'Addresses to Blind copy to
On Error Resume Next 'Ignore error if email is cancelled
DoCmd.SendObject , , , strTo, strCC, strBCC, strSubject, strMessage
strBCC = " "
End If
Loop
End With
Set db = Nothing
Set rs = Nothing
End Sub

Note: The sql is using a field name Email, so use the field name and table name accordingly in your database

lwells

Thank you. I'll look forward to the report in the body when you have a chance to think about it.

I put the code and function in and I get an error. While I understand the error, I don't know how to fix it. Is it because I put the source as qry_EmailPetwatchNotices instead of a table? That's the only thing I did differently.

Setting the source to your query shouldn't have been a problem. I suspect it is in the Function call....where did you place the function?...in the forms Module or global module?

To send your report as the body of your email...save your report as a text file and then replace this part of your code:

strMessage = "This is your Message Text"

With this

Open "C:\Report.txt" For Input As #1
While Not EOF(1)
Line Input #1, TextLine
strMessage = strMessage & TextLine & vbCrLf
Wend
Close #1

Be sure to use the correct path and file name in the above

Let me know about the function call.

lwells

I put it in the forms module. I'm not sure where else to put it. It sounds stupid of me to say this but I'm not sure which module is the global module. I'm having one of those days where everything I do on this database today isn't working.

What does "Textline" represent? It's giving me problems and I'm trying to work with it but am having trouble. I can't believe I'm asking such stupid questions.

Hmmm....with it working on my db it's a little puzzling...try this

Change this part:

If GetEmailAddress(rs, intNumber, varAddress) Then

to this

If GetEmailAddress(rs, intNumber, varAddress) = True Then

and add this snippet to the code after this

strBCC = " "

Else
Msgbox "GetEmailAddress is False"
Exit Do

End If

See if a message box pops up when you run the code.

Also did you compile the database?

lwells

OOps....Textline is a variable to hold the first read line of the txt document

Add
Dim Textline As String

Also what version of Access are you using?

I'm using 2000

I added the Dim and it went through, only it still puts the text file as an attachment instead of the body. I'm sorry to keep causing you work but I really need and appreciate any help you can give me.

I get the same error message box and debug goes to this line:

If GetEmailAddress(rs, intNumber, varAddress) = True Then

This is what I have for the code part:

Private Sub Command7_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strTo As String, strCC As String, strBCC As String
Dim strSubject As String, strMessage As String
Dim intNumber As Integer, intRecord As Integer
Dim strSQL As String
strSQL = "SELECT Email FROM qry_EmailPetwatchNotices " & _
"WHERE Email Is Not Null;"
strTo = "recipient@someaddress.com" 'Address to send to (required)
strCC = "recipient@someaddress.com" 'Address to copy to (optional)
strSubject = "Petwatch In Progress"
strMessage = ""
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
rs.MoveLast
If rs.RecordCount > 70 Then
intNumber = 70
Else
intNumber = rs.RecordCount
End If
With rs
.MoveFirst
Do Until rs.EOF
If GetEmailAddress(rs, intNumber, varAddress) = True Then
For intRecord = 0 To UBound(varAddress, 2)
strBCC = strBCC & varAddress(0, intRecord) & "; "
Next intRecord
strBCC = Left(strBCC, Len(strBCC) - 2) 'Addresses to Blind copy to
On Error Resume Next 'Ignore error if email is cancelled
DoCmd.SendObject , , , strTo, strCC, strBCC, strSubject, strMessage
strBCC = " "
Else
MsgBox "GetEmailAddress is False"
Exit Do
End If
Loop
End With
Set db = Nothing
Set rs = Nothing
End Sub


Oh, I compiled the modules and got the same result

I was able to duplicate your error. Go to Tools/References and move the DAO object library as far up as it will go. You probably have the default Microsoft ActiveX Data Objects library above the DAO library object. Another work around would be to specify the DAO library here in this line of code:

Function GetEmailAddress(rs As DAO.Recordset, _
intNumber As Integer, varAddress As Variant) As Boolean

After you have this solved then we will work out the issue of your report in the email body instead of as an attachment.

lwells

Got a different error this time.

I have the functions and codes on the module in the following order:

Function GetEmailAddress(rs As Recordset, _
intNumber As Integer, varAddress As Variant) As Boolean
varAddress = rs.GetRows(intNumber)
If intNumber > UBound(varAddress, 2) + 1 And Not rs.EOF Then
GetEmailAddress = False
Else
GetEmailAddress = True
End If
End Function

Function GetEmailAddress(rs As DAO.Recordset, _
intNumber As Integer, varAddress As Variant) As Boolean
End Function

Private Sub Command7_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strTo As String, strCC As String, strBCC As String
Dim strSubject As String, strMessage As String
Dim intNumber As Integer, intRecord As Integer
Dim strSQL As String
strSQL = "SELECT Email FROM qry_EmailPetwatchNotices " & _
"WHERE Email Is Not Null;"
strTo = "recipient@someaddress.com" 'Address to send to (required)
strCC = "recipient@someaddress.com" 'Address to copy to (optional)
strSubject = "Petwatch In Progress"
strMessage = ""
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
rs.MoveLast
If rs.RecordCount > 70 Then
intNumber = 70
Else
intNumber = rs.RecordCount
End If
With rs
.MoveFirst
Do Until rs.EOF
If GetEmailAddress(rs, intNumber, varAddress) = True Then
For intRecord = 0 To UBound(varAddress, 2)
strBCC = strBCC & varAddress(0, intRecord) & "; "
Next intRecord
strBCC = Left(strBCC, Len(strBCC) - 2) 'Addresses to Blind copy to
On Error Resume Next 'Ignore error if email is cancelled
DoCmd.SendObject , , , strTo, strCC, strBCC, strSubject, strMessage
strBCC = " "
Else
MsgBox "GetEmailAddress is False"
Exit Do
End If
Loop
End With
Set db = Nothing
Set rs = Nothing
End Sub

I moved the DOA up as far as I could.

Here's the error

YEAH!!! It works It works! I took the second function out after I figured out the error message. Your a genius!

Ok, I'm ready when you are to address the text in message body problem.

Thank you so much
Kris

Great, I will rewrite the code to include some error handling for you, but before I rewrite the code, lets work on the email body with your report.

Assuming you have already created your report with the information that you want to display as the body of the email, open your report in preview and using the tool bar select File/Export and then in the Save dialog box at the bottom for Save As Type select Text Files(*.txt;*.csv;*.tab;*.asc) from the drop down. Save the file to whatever directory you want and with whatever name you want the report name to be and then save.

Locate the full file path to this file and reply back with the full file path so I can code into the rewritten code for you. Example when saved to My Documents:

C:\Documents and Settings\user\My Documents\ReportName.txt

Besure to copy it as exactly how you have the file saved including the report name and extension.

lwells

Ok, here's what I have to date. I hate to keep throwing code out here but I tried to combine both issues and think I may have made a mess.


Function GetEmailAddress(rs As Recordset, _
intNumber As Integer, varAddress As Variant) As Boolean
varAddress = rs.GetRows(intNumber)
If intNumber > UBound(varAddress, 2) + 1 And Not rs.EOF Then
GetEmailAddress = False
Else
GetEmailAddress = True
End If
End Function


Private Sub EmailFlyer_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strTo As String, strCC As String, strBCC As String
Dim strSubject As String, strMessage As String
Dim intNumber As Integer, intRecord As Integer
Dim strSQL As String
Dim Textline As String
strSQL = "SELECT Email FROM qry_EmailPetwatchNotices " & _
"WHERE Email Is Not Null;"
strTo = "" 'Address to send to (required)
strCC = "" 'Address to copy to (optional)
strSubject = "Animal Found"
Open "C:\Documents and Settings\Kris\My Documents\PETWATCH\Flyers\rpt_FlyerFound.txt" For Input As #1
While Not EOF(1)
Line Input #1, Textline
strMessage = strMessage & Textline & vbCrLf
Wend
Close #1
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
rs.MoveLast
If rs.RecordCount > 70 Then
intNumber = 70
Else
intNumber = rs.RecordCount
End If
With rs
.MoveFirst
Do Until rs.EOF
If GetEmailAddress(rs, intNumber, varAddress) = True Then
For intRecord = 0 To UBound(varAddress, 2)
strBCC = strBCC & varAddress(0, intRecord) & "; "
Next intRecord
strBCC = Left(strBCC, Len(strBCC) - 2) 'Addresses to Blind copy to
On Error Resume Next 'Ignore error if email is cancelled
DoCmd.SendObject , , , strTo, strCC, strBCC, strSubject, strMessage
strBCC = " "
Else
MsgBox "GetEmailAddress is False"
Exit Do
End If
Loop
End With
Set db = Nothing
Set rs = Nothing
Dim stDocName As String
stDocName = "rpt_FlyerFound"
DoCmd.SendObject acReport, stDocName, , strTo, strCC, strBCC, strSubject, strMessage
Exit_Handler:
Exit Sub
Err_Handler:
If Err.Number = 2501 Then 'In case the email was canceled
Resume Exit_Handler
Else
MsgBox Err.Number & " " & Err.Description
Resume Exit_Handler
End If
End Sub

Hi Kris,

Okay replace the code behind the EmailFlyer_Click() with this code and you should be all set to go:

Private Sub EmailFlyer_Click()
On Error GoTo Err_Handler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strTo As String, strCC As String, strBCC As String
Dim strSubject As String, strMessage As String
Dim intNumber As Integer, intRecord As Integer
Dim strSQL As String, TextLine As String

strSQL = "SELECT Email FROM qry_EmailPetwatchNotices " & _
"WHERE Email Is Not Null;"

strTo = "" 'Address to send to (required)
strCC = "" 'Address to copy to (optional)
strSubject = "Animal Found"