Sending email through Outlook - code not looping 1

[AaronKamp]

I'm having a bit of difficulty with this code. In a simpler form it works just fine except line breaks in the contacts section of the body were not being shown when recieved by recipients.

In RTF format this is not the case; however, now the code no longer loops through the recordset. It only sends to the first record.

Help! I need it to loop through the entire recordset!!!

Function SponsorApproval1()
On Error GoTo SA_Error

Dim ESA As String
Dim Title As String
Dim Message As Integer
        
    ESA = "You are about to send emails to all Executive Sponsors with outstanding approvals." & (Chr(13)) & (Chr(13)) & "Do you want to continue?"
    Title = "Executive Sponsor Approval"
    Message = MsgBox(ESA, vbYesNo, Title)
      

Dim EmlTo As String
Dim EmlSubject As String
Dim EmlMessage As String
Dim dbs As Database
Dim rst As DAO.Recordset
Dim fmt As String
Dim bodyText As String

Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("SponsorApproval")

'the F in rst(F) refers to the field in the query holding the email addresses
With rst
    If .RecordCount <> 0 Then
        If Message = vbNo Then
        Exit Function
        Else
        Do While Not rst.EOF
            EmlTo = rst("Email")
            EmlSubject = "The '" & rst("Project Name") & "' report approval is past due."
            EmlMessage = rst("First") & "," & vbNewLine & vbNewLine & "Please review/approve the status report in the Strategic Platform Dashboard database. If you have any issues, please contact your Project Manager (" & rst("Manager 1") & " - x" & rst("phone") & ") or someone from the listing below." & vbNewLine & vbNewLine & "Thank you." & vbNewLine & vbNewLine & "Strategic Development Contacts:" & vbNewLine & rst("VP") & vbNewLine & rst("dba") & vbNewLine & rst("PC") & vbNewLine & rst("AC")
            With objEmail
                .To = EmlTo
                .Subject = EmlSubject
                .Body = EmlMessage
                .BodyFormat = olFormatRichText
                .Display
                End With
        .MoveNext
        Loop
        End If
    End If
End With


SA_Error:
Exit Function

End Function

 

[AaronKamp]

Here is the code that loops, however it will only send in text format.

Function SponsorApproval()
On Error GoTo SA_Error

Dim ESA As String
Dim Title As String
Dim Message As Integer
        
    ESA = "You are about to send emails to all Executive Sponsors with outstanding approvals." & (Chr(13)) & (Chr(13)) & "Do you want to continue?"
    Title = "Executive Sponsor Approval"
    Message = MsgBox(ESA, vbYesNo, Title)
      

Dim EmlTo As String
Dim EmlSubject As String
Dim EmlMessage As String
Dim dbs As Database
Dim rst As DAO.Recordset
Dim fmt As String
Dim bodyText As String

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("SponsorApproval")

'the F in rst(F) refers to the field in the query holding the email addresses
With rst
    If .RecordCount <> 0 Then
        If Message = vbNo Then
        Exit Function
        Else
        Do While Not rst.EOF
            EmlTo = rst("Email")
            EmlSubject = "The '" & rst("Project Name") & "' report approval is past due."
            EmlMessage = rst("First") & "," & vbNewLine & vbNewLine & "Please review/approve the status report in the Strategic Platform Dashboard database. If you have any issues, please contact your Project Manager (" & rst("Manager 1") & " - x" & rst("phone") & ") or someone from the listing below." & vbNewLine & vbNewLine & "Thank you." & vbNewLine & vbNewLine & "Strategic Development Contacts:" & vbNewLine & rst("VP") & vbNewLine & rst("dba") & vbNewLine & rst("PC") & vbNewLine & rst("AC")
            DoCmd.SendObject , , , EmlTo, "", "", EmlSubject, EmlMessage, True
        .MoveNext
        Loop
    End If
    End If
End With

SA_Error:
Exit Function

End Function

 

[earthandfire]

I'm surprised that either version loops.

Generally Access does not know the RecordCount when the Recordset is first opened.

I would use:

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("SponsorApproval")
Dim RecCount As Long
'If you know that there will always be records then you can skip the EOF/BOF check
If rst.EOF And rst.BOF Then
'set your objects to Nothing & Close the recordset
MsgBox "There are no records!!!"
Exit Sub
End If
rst.MoveLast
RecCount = rst.RecordCount
rst.MoveFirst
'then the rest of your code

Hope this helps.

 

[Eupher]

AaronKamp,

Are you certain it is not looping? Have you set a breakpoint and stepped through the procedure? Since the only thing that is different between the two versions of your code is the mechanism for sending the message, seems to me that maybe that is where the problem lies, not the loop itself. I'm not familiar with the Outlook API, so this is just off the cuff - but maybe the Display method does not suspend code execution? I dunno, just a thought...

BTW, I don't see any reason why the code would not loop because of this use of the RecordCount property. True, Access does not know the value of RecordCount when the recordset is first opened, but I've never seen RecordCount return 0 if there were records in the recordset - it should return 1. And the MoveNext method should keep it stepping until EOF, I should think. But in general principle I agree that BOF/EOF is probably a better test.

Ken S.

 

[earthandfire]

Euphor, you're quite correct. I noticed .RecordCount and completely forgot that the code was in a While .MoveNext Loop.

 

[RoyVidar]

In the second version, using the SendObject method, a new e-mail is created and sent per each iteration.

In the first version, you only create one e-mail

[tt]Set objEmail = objOutlook.CreateItem(olMailItem)[/tt]

I think you'll need to create one e-mail per iteration.

Put that line as the first line within the loop. (Perhaps also release it at the end of the loop?)

Using the .Display method, I think would pop up all e-mail messages on the screen, where you'd need to manually hit send for each of them, perhaps consider .Send?

Roy-Vidar

 

[AaronKamp]

Thanks, you guys rock!

Roy-Vidar's solution worked like a charm. I tried it first since it was the easiest to implement and test.

The original w/ the DoCmd.SendObject did loop through all records. I thought since I called the outlook message in the loop in the With, that it would loop. I'm pretty new to VBA and all of your insights, suggestions and questions have been a big help in both my edification and solving this issue.

I did change the .display to .send as was my original intent. When I was testing the code an email was accidentally got out to our CIO.