Solved Help on blank Email body (1 Viewer)

L

lookforsmt

Registered User.
Local time
Today, 20:03
Joined
Dec 26, 2011
Messages
672
HI!
i have previously got a solution here which was working fine. Recently without any warning the email body content shows blank.
However the email address is correct assigned.

Not sure why the body contents are not displayed.
I am sharing the previous vba code

Code: 
Private Sub send_mail_Click()
'modified by thedbguy@gmail.com
'8/22/2015

'Create application and mail objects
Dim olApp As Object
Dim objMail As Object
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim strID As String
Dim strTable As String
Dim strName As String
Dim strEmailTo As String
Dim strEmailcc As String
Dim rowColor As String
Dim i As Integer

Set db = CurrentDb()

'loop through query records
Set rs1 = CurrentDb.OpenRecordset("SELECT DISTINCT DispatchLocation FROM qryDataToSend", dbOpenSnapshot)

Do While Not rs1.EOF
Set rs2 = CurrentDb.OpenRecordset("SELECT * FROM qryDataToSend WHERE DispatchLocation='" & rs1!DispatchLocation & "'", dbOpenSnapshot)
Do While Not rs2.EOF
'Email header
' strName = rs2!DispatchLocation
strName = "<b><i>Dear All,</i></b><br>" & vbNewLine & vbCrLf & "<br><i>Below is the summary of returns and dispatch status</i><br>" _
& "<b><i></i></b><br>" _

strEmailTo = rs2!email_Id_To
strEmailcc = rs2!email_Id_cc
'list of courses
strTable = strTable & "<tr><td>" & rs2!CustomerAC & "</td>"
strTable = strTable & "<td align='center'>" & rs2!RejectReason & "</td>"
strTable = strTable & "<td align='center'>" & rs2!DispatchLocation & "</td>"
strTable = strTable & "<td align='center'>" & rs2!RejectDate & "</td>"
rs2.MoveNext
Loop
strTable = strTable & "</table>"

On Error Resume Next 'Keep going if there is an error
Set olApp = GetObject(, "Outlook.Application") 'See if Outlook is open

If Err Then 'Outlook is not open
Set olApp = CreateObject("Outlook.Application") 'Create a new instance
End If

'Create e-mail item
Set objMail = olApp.CreateItem(olMailItem)
'-------------------------------------------------------------
i = 0
'Do While Not rs1.EOF
If (i Mod 2 = 0) Then
rowColor = "<td align=center bgcolor='#FFFFFF'> "
Else
rowColor = "<td align=center bgcolor='#E1DFDF'> "
End If
'---------------------------------------------------------------
With objMail
.BodyFormat = olFormatHTML
.To = strEmailTo
.CC = strEmailcc
.Subject = "NPDD Deadline Reminder"
.HTMLBody = "<!DOCTYPE html>"
.HTMLBody = .HTMLBody & "<html><head><style>table, th, td {border: 1px solid black;}</style></head><body>"
' .HTMLBody = .HTMLBody & "Dear " & strName & "," & "<p>"
.HTMLBody = .HTMLBody & strName & "<p>"
' .HTMLBody = .HTMLBody & "Below are your courses that the NPDD deadline is near blah blah ..."
.HTMLBody = .HTMLBody & "<table style='width:40%'>" 'Change table width here
.HTMLBody = .HTMLBody & "<tr bgcolor='#7EA7CC'><td>CustomerAC</td>" 'Change head row back color here
.HTMLBody = .HTMLBody & "<td align='center'>RejectReason</td>"
.HTMLBody = .HTMLBody & "<td align='center'>DispatchLocation</td>"
.HTMLBody = .HTMLBody & "<td align='center'>RejectDate</td></tr>"
.HTMLBody = .HTMLBody & strTable

'Add signatue line end of the body and send
' .HTMLBody = .HTMLBody & "</table><p>" & "Signature" & "<br>" & "Company" & "</body></html>"
.HTMLBody = .HTMLBody & "</table><p>" & "Thanks and Regards" & "</body></html>"

'.send
.Display
End With
strTable = ""
rs1.MoveNext
'-------------------------------------------------------------------
' rs.MoveNext
i = i + 1
'Loop

'-------------------------------------------------------------------
Loop
If strTable = "" Then
MsgBox "NO Data Found!!!"
Exit Sub 'Exit the sub routine.
End If
'----------------------------------------------------------
MsgBox "Reports have been sent", vbOKOnly

Set rs2 = Nothing
Set rs1 = Nothing
Set db = Nothing
Set olApp = Nothing
Set objMail = Nothing

End Sub
 
Hi. When you say the body is empty, is it totally empty, or do you see something, just not everything?
 
No Sir, it is completely blank, except the email address are correctly placed
 
lookforsmt said:
No Sir, it is completely blank, except the email address are correctly placed
Click to expand...
Okay, if this used to work and then suddenly it doesn't, maybe something has changed with the computer. Did you install any new updates or software? Have you tried using a different computer? To help you troubleshoot this, you may have to post a sample copy of your db with test data.
 
Could you add a debug.print .htmlbody after the last html body statement and view in the debug window. Or alternatively put a breakpoint after the last .htmlbody and do a ? .htmlbody in the immediate window and see what is displayed?
 
Please indent your code so others - and yourself - are able to read and follow it.
 
Perhaps start checking your recordsets?
Walk through the code with F8 after setting a breakpoint?
 
HI! I did some changes in the above code. I am now able to get the details in body of the email. But there is one issue now, the email recipient names are missing. any suggestions what i have done wrong here pls
below is the code

Code: 
Private Sub send_mail_Click()
'modified by thedbguy@gmail.com
'8/22/2015

'Create application and mail objects
    Dim olApp As Object
    Dim objMail As Object
    Dim db As DAO.Database
    Dim rs1 As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim strID As String
    Dim strTable As String
    Dim strName As String
    Dim strEmailTo As String
    Dim strEmailcc As String
    Dim rowColor As String
    Dim i As Integer
    Dim strDate As String
    Dim strGreeting As String
    Dim sqlString As String
    Dim asPostTable As String
    Dim rs As ADODB.Recordset

Set rs = New ADODB.Recordset
Set db = CurrentDb()

'loop through query records
Set rs1 = CurrentDb.OpenRecordset("SELECT DISTINCT DispatchLocation FROM qryDataToSend", dbOpenSnapshot)

Do While Not rs1.EOF
    Set rs2 = CurrentDb.OpenRecordset("SELECT * FROM qryDataToSend WHERE DispatchLocation='" & rs1!DispatchLocation & "'", dbOpenSnapshot)
    Do While Not rs2.EOF
        'Email header

    strName = "<b><i>Dear All,</i></b><br>" & vbNewLine & vbCrLf & "<br><i>Below is the summary of dispatch status</i><br>" _
    & "<b><i></i></b><br>" _

    sqlString = "SELECT DISTINCT DispatchLocation FROM qryDataToSend"
    rs.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
'--------------------------------------------------------------------------------
    strTable = "<table border='1' cellpadding='3' cellspacing='3' style='border-collapse: collapse' bordercolor='#111111' width='1200'>" & _
        "<tr>" & _
        "<td bgcolor='#7EA7CC'> <b>Reject Date</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>Customer AC</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>Reject Reason</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>Dispatch Location</b></td>" & _
        "</tr>"
    i = 0
        Do While Not rs2.EOF

    If (i Mod 2 = 0) Then
        rowColor = "<td align=center bgcolor='#FFFFFF'> " '
    Else
        rowColor = "<td align=center bgcolor='#E1DFDF'> "
    End If

    strTable = strTable & "<tr>" & _
        rowColor & Nz(rs2.Fields("RejectDate"), "") & "</td>" & _
        rowColor & Nz(rs2.Fields("CustomerAC"), "") & "</td>" & _
        rowColor & Nz(rs2.Fields("RejectReason"), "") & "</td>" & _
        rowColor & Nz(rs2.Fields("DispatchLocation"), "") & "</td>" & _
        "</tr>"
    rs2.MoveNext
    i = i + 1
    Loop
    strTable = strTable & "</table>"
'--------------------------------------------------------------------------------
    asPostTable = "<br><b><i>Thanks and Regards</i></b><br>"
        strEmailTo = rs2!email_Id_To
        strEmailcc = rs2!email_Id_cc
'-------------------------------------------------------------------------------
    Loop

    On Error Resume Next 'Keep going if there is an error
    Set olApp = GetObject(, "Outlook.Application") 'See if Outlook is open
    
    If Err Then 'Outlook is not open
        Set olApp = CreateObject("Outlook.Application") 'Create a new instance
    End If
    
    'Create e-mail item
    Set objMail = olApp.CreateItem(olMailItem)
'-------------------------------------------------------------
    With objMail
        .BodyFormat = olFormatHTML
        .To = strEmailTo
        .CC = strEmailcc
        .Subject = "NPDD Deadline Reminder"
        .HTMLBody = strName & strTable & asPostTable

        Debug.Print .HTMLBody
        
        '.send
        .Display
    End With
    strTable = ""
    rs1.MoveNext
'-------------------------------------------------------------------
'    rs.MoveNext
    i = i + 1
    Loop
    strTable = strTable & "</table>"
'-------------------------------------------------------------------
'Loop
    If strTable = "" Then
            MsgBox "NO Data Found!!!"
        Exit Sub 'Exit the sub routine.
    End If
'----------------------------------------------------------
        MsgBox "Reports have been sent", vbOKOnly

    Set rs2 = Nothing
    Set rs1 = Nothing
    Set db = Nothing
    Set olApp = Nothing
    Set objMail = Nothing
    
End Sub
 
Compare your posted code in this thread from before and now.

You have to approach this logically, not just change code adhoc.?

Thinks of the steps you are taking.?

Hint: Your email addresses were coming from recordset 2
 
Here is the same code indented properly which may help;
SQL: 
Private Sub send_mail_Click()
    'modified by thedbguy@gmail.com
    '8/22/2015

    'Create application and mail objects
    Dim olApp As Object
    Dim objMail As Object
    Dim db As DAO.Database
    Dim rs1 As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim strID As String
    Dim strTable As String
    Dim strName As String
    Dim strEmailTo As String
    Dim strEmailcc As String
    Dim rowColor As String
    Dim i As Integer
    Dim strDate As String
    Dim strGreeting As String
    Dim sqlString As String
    Dim asPostTable As String
    Dim rs As ADODB.Recordset

    Set rs = New ADODB.Recordset
    Set db = CurrentDb()

    'loop through query records
    Set rs1 = CurrentDb.OpenRecordset("SELECT DISTINCT DispatchLocation FROM qryDataToSend", dbOpenSnapshot)

    Do While Not rs1.EOF
        Set rs2 = CurrentDb.OpenRecordset("SELECT * FROM qryDataToSend WHERE DispatchLocation='" & rs1!DispatchLocation & "'", dbOpenSnapshot)
        Do While Not rs2.EOF
            'Email header

            strName = "<b><i>Dear All,</i></b><br>" & vbNewLine & vbCrLf & "<br><i>Below is the summary of dispatch status</i><br>" _
                & "<b><i></i></b><br>" _

                sqlString = "SELECT DISTINCT DispatchLocation FROM qryDataToSend"
                rs.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
                '--------------------------------------------------------------------------------
                strTable = "<table border='1' cellpadding='3' cellspacing='3' style='border-collapse: collapse' bordercolor='#111111' width='1200'>" & _
                    "<tr>" & _
                    "<td bgcolor='#7EA7CC'> <b>Reject Date</b></td>" & _
                    "<td bgcolor='#7EA7CC'> <b>Customer AC</b></td>" & _
                    "<td bgcolor='#7EA7CC'> <b>Reject Reason</b></td>" & _
                    "<td bgcolor='#7EA7CC'> <b>Dispatch Location</b></td>" & _
                    "</tr>"
                i = 0
                Do While Not rs2.EOF

                    If (i Mod 2 = 0) Then
                        rowColor = "<td align=center bgcolor='#FFFFFF'> " '
                    Else
                        rowColor = "<td align=center bgcolor='#E1DFDF'> "
                    End If

                    strTable = strTable & "<tr>" & _
                        rowColor & Nz(rs2.Fields("RejectDate"), "") & "</td>" & _
                        rowColor & Nz(rs2.Fields("CustomerAC"), "") & "</td>" & _
                        rowColor & Nz(rs2.Fields("RejectReason"), "") & "</td>" & _
                        rowColor & Nz(rs2.Fields("DispatchLocation"), "") & "</td>" & _
                        "</tr>"
                    rs2.MoveNext
                    i = i + 1
                Loop
                strTable = strTable & "</table>"
                '--------------------------------------------------------------------------------
                asPostTable = "<br><b><i>Thanks and Regards</i></b><br>"
                strEmailTo = rs2!email_Id_To
                strEmailcc = rs2!email_Id_cc
                '-------------------------------------------------------------------------------
        Loop

        On Error Resume Next 'Keep going if there is an error
        Set olApp = GetObject(, "Outlook.Application") 'See if Outlook is open
    
        If Err Then 'Outlook is not open
            Set olApp = CreateObject("Outlook.Application") 'Create a new instance
        End If
    
        'Create e-mail item
        Set objMail = olApp.CreateItem(olMailItem)
        '-------------------------------------------------------------
        With objMail
            .BodyFormat = olFormatHTML
            .To = strEmailTo
            .CC = strEmailcc
            .Subject = "NPDD Deadline Reminder"
            .HTMLBody = strName & strTable & asPostTable

            Debug.Print .HTMLBody
        
            '.send
            .Display
        End With
        strTable = ""
        rs1.MoveNext
        '-------------------------------------------------------------------
        i = i + 1
    Loop
    strTable = strTable & "</table>"
    '-------------------------------------------------------------------
    If strTable = "" Then
        MsgBox "NO Data Found!!!"
        Exit Sub 'Exit the sub routine.
    End If
    '----------------------------------------------------------
    MsgBox "Reports have been sent", vbOKOnly

    Set rs2 = Nothing
    Set rs1 = Nothing
    Set db = Nothing
    Set olApp = Nothing
    Set objMail = Nothing
    
End Sub
 
You should not use On Error Resume Next without resuming normal error handling after the test for GetObject

Think about it. This is telling Access "If an error is encountered during the rest of this code, don't tell me anything about it so I have no idea it's happening and try to continue". It makes no sense to do that.

Get rid of that and you will be able to debug this yourself
 
i HI! Isaac, i am getting a error, " Object doesnt support the property or method"
 
'Create e-mail item
Set objMail = olApp.CreateItem(olMailItem)
 
I *thought* if you used Late Binding, you could not use any specific app constants?
 
i will not be able to comment on this due to my poor knowledge on vba.
If anyone can help me on this, really appreciate this
 
Replace your error line with

Set objMail = olApp.CreateItem(0)

Access doesn't know what olMailItem is. It's an Outlook enumerated value. (Like a constant)
If you get some similar issues, further on then look up the value that Outlook would enumerate from the constant.
 
Minty said:
Replace your error line with

Set objMail = olApp.CreateItem(0)

Access doesn't know what olMailItem is. It's an Outlook enumerated value. (Like a constant)
If you get some similar issues, further on then look up the value that Outlook would enumerate from the constant.
Click to expand...
Thank you for confirming that @Minty
So I am so puzzled now as to how it all worked before :unsure:
 
You must log in or register to reply here.

Similar threads

M
Signature Image in GMail email body
Replies
6
Views
244
xavier.batlle
X
A
Solved Help with handling of Null
2 3
Replies
53
Views
2,752
allen675
A
M
Solved VBA access to outlook email with table: aligning table cells
Replies
5
Views
2,270
miacino
M
A
Copy Selected (Protected - Column Headers) Rows/Cells Into Body Of The Email As Image
Replies
3
Views
582
Gasman
Gasman
T
HTML EMAIL
Replies
6
Views
895
cheekybuddha
cheekybuddha

Users who are viewing this thread

Total: 2 (members: 0, guests: 2)
Back
Top Bottom