Working in Office 2007. This application was originally written to email from Outlook, later converted to Lotus Notes and now back to Outlook (no, they did not leave the old Outlook code behind).
Got it working fairly nicely to generate emails. The problem is that after displaying an email, the code loops to go generate the next one. When that completes, it overwrites the last one generated.
I need to display all the emails before someone verifies info and manually clicks Send.
Everything works except for the overwriting the already displayed emails.
Alan
![[smurf]](/data/assets/smilies/smurf.gif "[smurf] [smurf]")
Got it working fairly nicely to generate emails. The problem is that after displaying an email, the code loops to go generate the next one. When that completes, it overwrites the last one generated.
I need to display all the emails before someone verifies info and manually clicks Send.
Code:
Public Function fncEmail()
' Send to email
Dim db As Database
Dim rst As Recordset
Dim rstLog As Recordset
Dim rstRecip As Recordset
Dim rstEmail As Recordset
Dim rstMessage As Recordset
Dim mailObj As Outlook.MailItem ' 03/05/10 ARB
Dim myAttachments As Outlook.Attachments
Dim objRecipient As Outlook.Recipient
Dim strSubject As String, strMessage As String, strAttachment As String
Dim strRecip As String, strAcct As String
Dim blAttach As Boolean, strEmailType As String, strCC As String
Dim atxMapiSession
Dim atxMessages
Dim strAllEmail As Boolean
Dim strSignedoffEmail As String, strapprovedEmail As String
Dim strSql As String
gblfilterdate = Me!FilterDate [highlight]'1st step after clicking Email button[/highlight]
Set mailObj = Outlook.Application.CreateItem(olMailItem)
On Error GoTo EmailErr
Set db = CurrentDb
If optReporttoPrint = 1 Or optReporttoPrint = 2 Then
Select Case optReporttoPrint
Case 1
'Account Reviews
CurrentDb().QueryDefs.Item("QuickAcctList").SQL = "exec sp_QuickAcctList '" _
& gblfilterdate & "'"
strSubject = "Acct Reviews" 'sets Email subject
strEmailType = "AcctReviews"
Let mailObj.Subject = strSubject '03/05/10
Select Case Me!optRptAcctReview
Case 1 'Neither signed off or approved
Set rstRecip = db.OpenRecordset("SELECT dbo_AcctMaster.Reconciler, dbo_AcctMaster.Reviewer, dbo_AcctMaster.ContactANumber, dbo_AcctMaster.ANumberReviewer FROM (QuickAcctList LEFT JOIN dbo_AcctMaster ON QuickAcctList.AcctNo = dbo_AcctMaster.AcctNo) LEFT JOIN dbo_Contacts ON dbo_AcctMaster.ContactANumber = dbo_Contacts.ANumber WHERE (((QuickAcctList.ReconANumber) Is Null) And ((QuickAcctList.ManagerANumber) Is Null)) GROUP BY dbo_AcctMaster.Reconciler, dbo_AcctMaster.Reviewer, dbo_AcctMaster.ContactANumber, dbo_AcctMaster.ANumberReviewer ORDER BY dbo_AcctMaster.Reconciler;")
Case 2 'Signed off only
Set rstRecip = db.OpenRecordset("SELECT dbo_AcctMaster.Reconciler, dbo_AcctMaster.ContactANumber, dbo_AcctMaster.Reviewer, dbo_AcctMaster.ANumberReviewer FROM (QuickAcctList LEFT JOIN dbo_AcctMaster ON QuickAcctList.AcctNo = dbo_AcctMaster.AcctNo) LEFT JOIN dbo_Contacts ON dbo_AcctMaster.ContactANumber = dbo_Contacts.ANumber WHERE (((QuickAcctList.ReconANumber) Is Not Null) And ((QuickAcctList.ManagerANumber) Is Null)) GROUP BY dbo_AcctMaster.Reconciler, dbo_AcctMaster.ContactANumber, dbo_AcctMaster.Reviewer, dbo_AcctMaster.ANumberReviewer ORDER BY dbo_AcctMaster.Reconciler;")
End Select
[highlight] 'recordset gives me a list of who needs an email[/highlight]
If Not rstRecip.BOF Then
rstRecip.MoveFirst
Do Until rstRecip.EOF
Call SysCmd(acSysCmdSetStatus, "Creating email for " & rstRecip!Reconciler & " and " & rstRecip!Reviewer & ".")
'strRecip = rstRecip!Email
strRecip = Nz(DLookup("Email", "dbo_Contacts", "ANumber = '" & rstRecip!ANumberReviewer & "'"), rstRecip!Reviewer)
strCC = Nz(DLookup("Email", "dbo_Contacts", "Anumber = '" & rstRecip!ContactANumber & "'"), rstRecip!ContactANumber)
strMessage = DLookup("Message", "tblEmailMessage", "ReportType = '" & strEmailType & "'") & vbCrLf & vbCrLf
strMessage = strMessage & vbCrLf & vbCrLf
'use this code to build a message
Select Case Me!optRptAcctReview
Case 1 'Neither signed off or approved
Set rstMessage = db.OpenRecordset("SELECT QuickAcctList.AcctNo, " _
& " QuickAcctList.AcctName FROM (QuickAcctList LEFT JOIN dbo_AcctMaster ON QuickAcctList.AcctNo = dbo_AcctMaster.AcctNo) LEFT JOIN dbo_Contacts ON dbo_AcctMaster.ContactANumber = dbo_Contacts.ANumber WHERE (((dbo_AcctMaster.Reconciler) = '" & rstRecip!Reconciler & "') And ((dbo_AcctMaster.Reviewer) = '" & rstRecip![Reviewer] & "') And ((QuickAcctList.ReconANumber) Is Null) And ((QuickAcctList.ManagerANumber) Is Null)) GROUP BY QuickAcctList.AcctNo, QuickAcctList.AcctName;")
Case 2 'Signed off only
Set rstMessage = db.OpenRecordset("SELECT QuickAcctList.AcctNo, " _
& "QuickAcctList.AcctName FROM (QuickAcctList LEFT JOIN dbo_AcctMaster ON QuickAcctList.AcctNo = dbo_AcctMaster.AcctNo) LEFT JOIN dbo_Contacts ON dbo_AcctMaster.ContactANumber = dbo_Contacts.ANumber WHERE (((dbo_AcctMaster.Reconciler) = '" & rstRecip!Reconciler & "') And ((dbo_AcctMaster.Reviewer) = '" & rstRecip![Reviewer] & "') And ((QuickAcctList.ReconANumber) Is Not Null) And ((QuickAcctList.ManagerANumber) Is Null)) GROUP BY QuickAcctList.AcctNo, QuickAcctList.AcctName;")
End Select
If Not rstMessage.BOF Then
rstMessage.MoveFirst
Do Until rstMessage.EOF
strMessage = strMessage & rstMessage!AcctNo & vbTab & rstMessage!AcctName & vbCrLf
rstMessage.MoveNext
Loop
End If
Let mailObj.Body = strMessage '03/05/2010
mailObj.To = strRecip
mailObj.CC = strCC
'check for null addresses
Call SysCmd(acSysCmdSetStatus, "Checking email address")
mailObj.Display [highlight #FF0000]'Goofy 06/02/10 ---- overwriting at this point
'Handling error numb wrong 05/5/10
'update email address[/highlight]
Call SysCmd(acSysCmdSetStatus, "Adding email information to log file")
If IsNull(rstRecip!Email) Then
Set rstEmail = db.OpenRecordset("SELECT dbo_Contacts.ANumber, dbo_Contacts.EMail FROM dbo_Contacts WHERE (((dbo_Contacts.ANumber)='" & rst!ContactANumber & "'));")
If Not rstEmail.BOF Then
With rstEmail
.Edit
!Email = mailObj.To .Update
End With
End If
End If
'append email information to log file
Set rstLog = db.OpenRecordset("tblEmailLog", dbOpenDynaset)
With rstLog
.AddNew
!AccountNumber = strAcct
!recipname = mailObj.To
!EmailSubject = mailObj.Subject
!EmailMsg = mailObj.Body
!EmailDate = Now()
.Update
End With
rstRecip.MoveNext
Loop
strMessage = "" '06/15/10
Set rstMessage = Nothing
strEmailType = ""
strSubject = ""
Else
MsgBox "Nothing to email", vbInformation, "Acct Reviews"
End If
Case 2
'Miscellaneous Money Differences
strSubject = "Suspense Account Recon, Misc Money Difference"
strEmailType = "MiscMoney"
gblfilterdate = Me!FilterDate
Call fncMiscMoney(gblfilterdate)
Set rst = db.OpenRecordset("SELECT ContactANumber, EMail FROM tblMiscMoneyDiff WHERE (((ContactANumber) Is Not Null)) Or (((Email) Is Not Null)) GROUP BY ContactANumber, EMail;")
Call SysCmd(acSysCmdSetStatus, "Creating email")
If Not rst.BOF Then
rst.MoveFirst
Select Case optReporttoPrint
Case 1
strRecip = rst!Reconciler
strAcct = rst!AcctNo
blAttach = True
Case 2
blAttach = False
End Select
Do Until rst.EOF
strMessage = DLookup("Message", "tblEmailMessage", "ReportType = '" & strEmailType & "'") & vbCrLf & vbCrLf
strMessage = strMessage & "Account Number" & vbCrLf
strRecip = IIf(IsNull(rst!Email), rst!ContactANumber, rst!Email)
Set rstEmail = db.OpenRecordset("SELECT tblMiscMoneyDiff.AcctNo, tblMiscMoneyDiff.AcctName, tblMiscMoneyDiff.DeptName, Sum(tblMiscMoneyDiff.MiscMoney) AS SumOfMiscMoney, Sum(tblMiscMoneyDiff.TotalMiscEntries) AS SumOfTotalMiscEntries, Sum(tblMiscMoneyDiff.Unreconciled) AS SumOfUnreconciled FROM tblMiscMoneyDiff WHERE (((tblMiscMoneyDiff.ContactANumber)='" & rst!ContactANumber & "')) GROUP BY tblMiscMoneyDiff.AcctNo, tblMiscMoneyDiff.AcctName, tblMiscMoneyDiff.DeptName HAVING (((Sum(tblMiscMoneyDiff.Unreconciled))<>0));")
If Not rstEmail.BOF Then
rstEmail.MoveFirst
Do Until rstEmail.EOF
'strMessage = strMessage & rstEmail!AcctNo & vbTab & vbTab & rstEmail!SumOfMiscMoney & String(20 - Len(rstEmail!SumOfMiscMoney), " ") & rstEmail!SumOfUnreconciled & String(20 - Len(rstEmail!SumOfUnreconciled), " ") & rstEmail!AcctName & vbCrLf
strMessage = strMessage & rstEmail!AcctNo & vbCrLf
rstEmail.MoveNext
Loop
Let mailObj.Body = strMessage '06/02
mailObj.Subject = strSubject
mailObj.To = strRecip
mailObj.CC = strCC
If blAttach = True Then
'attachmentProperties
mailObj.Attachments = strAttachment
End If
'check for null addresses
Call SysCmd(acSysCmdSetStatus, "Checking email addresses")
mailObj.Display [highlight #FF0000]'06/08/2010 ARB
'append email information to log file[/highlight]
Call SysCmd(acSysCmdSetStatus, "Adding email information to log file")
If IsNull(rst!Email) Then
Set rstEmail = db.OpenRecordset("SELECT dbo_Contacts.ANumber, dbo_Contacts.EMail FROM dbo_Contacts WHERE (((dbo_Contacts.ANumber)='" & rst!ContactANumber & "'));")
If Not rstEmail.BOF Then
With rstEmail
.Edit
!Email = mailObj.To
.Update
End With
End If
End If
Set rstLog = db.OpenRecordset("tblEmailLog", dbOpenDynaset)
With rstLog
.AddNew
!AccountNumber = strAcct
!recipname = mailObj.To
!EmailSubject = mailObj.Subject
!EmailMsg = mailObj.Body
!EmailDate = Now()
.Update
End With
End If
rst.MoveNext
Loop
strMessage = "" '06/15/10
Set rstMessage = Nothing
strEmailType = ""
strSubject = ""
End If
Case Else
End Select
Else
MsgBox "This report does not have an email option. Please choose the print button.", vbCritical, "Email Report"
Exit Function
End If
MsgBox "Email Complete", vbInformation, "Note"
EmailErrDone:
Set rst = Nothing
Set rstLog = Nothing
Set mailObj = Nothing
Set rstRecip = Nothing
Set rstEmail = Nothing
Set rstMessage = Nothing
Call SysCmd(acSysCmdClearStatus)
DoCmd.Hourglass False
Exit Function
EmailErr:
If Err.Number = 32050 Or 32002 Then
Resume Next
Else
ErrorHandler Err.Number, Err.Description, "fncEmail, frmReportOptions"
Resume EmailErrDone
End If
End FunctionAlan