Dorian Thank You for taking a look at my question. I will try to better
describe & specify my problem and attach theVBA code. First I have a form
(frmSupplierReportCardEmailForm) with 3 List Boxes to select the Group (this
is a group of suppliers and their Email info), the Year and the Month. These
variables are cbogroup, cboYear, cboMonth. The form also contains a command
button to send Emails. The on Click Event is
"SendMessages("C:\SupplierReportCard.snp"). SupplierReportCard is the report
attached to the MS Outlook Email message.
The query qryMailingList are the suppliers and their associated email info
fields. The intent is for cboGroup to filter qryMailingList so I only get the
supplier records which are part of the cboGroup selected. This set of records
is set as the record set to loop through sending emails with attached reports
to each supplier.
I really hope this is somewhat clear.
following is the Module1 VBA code
Option Compare Database
Dim ESuppID As String
Dim EBody As String
Dim ESubject As String
Dim cboYear As String
Dim cboMonth As String
Dim recCount As Integer
Dim GroupName As String
Dim cboGroup As String
Option Explicit
Sub SendMessages(Optional AttachmentPath)
Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim TheAddress As String
Dim Report11 As String
Dim EPerson As String
Dim EIntro As String
Dim EMsg As String
Dim ESuppNme As String
Dim EAttachNote As String
Dim CCPerson As String
'Dim TheID As Integer
Dim TheWhereClause As String
'Dim SupprNo As String
EAttachNote = "EmailAttachmsg"
GroupName = GetGroup()
Debug.Print GroupName
Debug.Print cboGroup
Debug.Print GetGroup()
Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("qryMailingList")
MyRS.MoveFirst
'Create the Outlook Session.
Set objOutlook = CreateObject("Outlook.Application")
Do Until MyRS.EOF
'Create e-mail message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = MyRS![TempEmailAddress]
'TheAddress = MyRS![EmailContactAddress]
EPerson = MyRS![EmailContact]
EIntro = MyRS![EmailIntroMsg]
EMsg = MyRS![EmailMsgs]
ESuppID = MyRS![SupplierID]
'SupprNo = ESuppID
ESuppNme = MyRS![SupplierName]
CCPerson = MyRS![CCAddress]
EAttachNote = MyRS![EmailAttachMsg]
'cboYear = "2009"
'cboMonth = "July"
Debug.Print cboYear
Debug.Print cboMonth
' Adding Mark Andrew's suggested code
'TheID = MyRS![ID]
With objOutlookMsg
'Add the To recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add(TheAddress)
objOutlookRecip.Type = olTo
Debug.Print ESuppID
'Add the CC recipients to the e-mail message.
If (IsNull(CCPerson)) Then
Else
Set objOutlookRecip = .Recipients.Add(CCPerson)
objOutlookRecip.Type = olCC
End If
'Set the Subject, Body and Importance of the e-mail message.
ESubject = "SWS Supplier Report Card for " & ESuppNme & "--" & cboMonth & ",
" & cboYear
'.Subject = Forms!frmMail!Subject
..Subject = ESubject
'.Body = MyRS![EmailIntro]
'Body of E-mail Message has Dear Email person name, skip 2 lines,
Introduction, skip 2 lines, email message, skip 2 lines
'Email attachment note for SNP & PDF attachments
EBody = "Dear " & EPerson & vbCrLf & vbCrLf & EIntro & vbCrLf & vbCrLf &
EMsg & vbCrLf & vbCrLf & EAttachNote
..Body = EBody
'.Body = Forms!frmMail![MainText]Se
..Importance = olImportanceHigh 'High Importance
'Open Report code below
'Open rptSelectSupplierReportCard
'DoCmd.OpenReport "rptSelectSupplierReportCard", acViewPreview
DoCmd.OpenReport "rptSelectSupplierReportCardGF", acViewPreview
'Open Report1
'TheWhereClause = "(ID =" & TheID & ")"
'DoCmd.OpenReport "Report11", acViewPreview, , TheWhereClause
'DoCmd.OutputTo As
Debug.Print "WhereClause = " & TheWhereClause
Debug.Print ESuppID
Debug.Print cboMonth
'Note! this is where I need to check if the qryPurchasingTable with
variables passed for a specific Supplier has
'zero records. If so branch to the record set loop and increment to next
supplier. E-mail is NOT to be sent to
'Supplier if Report Card for period is blank.
'DoCmd.OpenQuery "qryThisSupplier" 'Note it appears this statement is not
needed but can be used for testing
recCount = DCount("*", "qryThisSupplier")
Debug.Print recCount
If recCount = 0 Then
DoCmd.Close acReport, "rptSelectSupplierReportCardGF", acSaveNo
GoTo IncrementLoopUp
End If
'DoCmd.OutputTo acOutputReport, "Report11", "Snapshot Format"
'DoCmd.OutputTo acOutputReport, "rptSelectSupplierReportCard", "Snapshot
Format", AttachmentPath
DoCmd.OutputTo acOutputReport, "rptSelectSupplierReportCardGF", "Snapshot
Format", AttachmentPath
'DoCmd.OutputTo acOutputReport, "Report11", "Snapshot Format", AttachmentPath
'DoCmd.SetWarnings ("False")
ConvertReportToPDF "rptSelectSupplierReportCardGF", ,
"C:\SupplierReportCard.PDF", , False
' It appears the next statement is not needed as the statements below checks
for a attachment
' and saves to C:\TestReportAttachment path if it exists so the below
statement is commented out
'Set objOutlookAttach = .Attachments.Add("C:\TestReportAttachment.snp")
'Add attachments to the e-mail message.
If Not IsMissing("AttachmentPath") Then
Set objOutlookAttach = .Attachments.Add(AttachmentPath)
Set objOutlookAttach = .Attachments.Add("C:\SupplierReportCard.PDF")
End If
' Resolve each Recipent's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
MsgBox ESuppID
MsgBox EPerson
..Send ' Send Email message with attachments via Outlook
'Here is where we need to close the report SupplierReportCard and the PDF
version of it
'DoCmd.Close acReport, "Report11", acSaveNo
'DoCmd.Close acReport, "rptSelectSupplierReportCard", acSaveNo
DoCmd.Close acReport, "rptSelectSupplierReportCardGF", acSaveNo
End With
'This deletes the current Supplier Report Card so it can be replaced by the
next Supplier Report Card in the Recordset.
Kill (AttachmentPath)
'Kill PDF Report Path
Kill ("C:\SupplierReportCard.PDF")
'End With - Temporary change to move up the end with so the snp report gets
deleted after being sent
IncrementLoopUp:
MyRS.MoveNext
Loop
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub
Public Function GetSupplierID() As String
GetSupplierID = ESuppID
End Function
Public Function GetYear() As String
GetYear = cboYear
End Function
Public Function GetMonth() As String
GetMonth = cboMonth
End Function
Public Function GetGroup() As String
GetGroup = cboGroup
End Function
