I have the following code that I want to use to automate sending reports to various clinic managers. The CODE will currently:
1. Add the Subject Line
2. Add the Body Text
3. Add the “Dear” + “Contact_First” and “To:Email”
4. Loop through all “Contact_First” and “email”
5. And Saves all email in my Outlook Draft folder
My Code will not Print my report based upon the date range entered into my form “frmEmailAllReports”
And
It will not add the Attachment to the email after creating the report for each clinic based upon the query “qryMyEmailAddresses”
And
It does not add a copy of the attachment to my “temp” folder.
Please Help…..
Here is my current code:
1. Add the Subject Line
2. Add the Body Text
3. Add the “Dear” + “Contact_First” and “To:Email”
4. Loop through all “Contact_First” and “email”
5. And Saves all email in my Outlook Draft folder
My Code will not Print my report based upon the date range entered into my form “frmEmailAllReports”
And
It will not add the Attachment to the email after creating the report for each clinic based upon the query “qryMyEmailAddresses”
And
It does not add a copy of the attachment to my “temp” folder.
Please Help…..
Here is my current code:
Code:
'Sources: "frmEmailAllReports" = txtStartDate, txtEndDate, cboClinic_Name
'.......: "Contacts1" = Table including Clinic_Name, Email,Contact_First, Contact_Last
'.......: "Results" = Table including Clinic_Name, Call Results
'.......: "qryMyEmailAddresses" SELECT Results.Clinic_Name, Results.Clinic_Staff_Name, Results.Time_of_Call, Results.Length_of_Call, Results.Date_of_call,
'Results.TimeOnHold, Results.Hold, Results.First_Available_Date, Results.Promptness, Results.ID_self, Results.ID_dept, Results.Offered_Assistance,
'Results.Tone, Results.Pace, Results.Respect, Results.Connected, Results.Hold_protocol, Results.Exit, Results.Call_Terminated, Results.Comments,
'Contacts1.Contact_First, Contacts1.Contact_Last, Contacts1.Email FROM Results INNER JOIN Contacts1 ON Results.Clinic_Name = Contacts1.Clinic_Name
'WHERE (((Results.Clinic_Name)=[Form]![frmEmailAllReports]![txtClinic_Name]) AND ((Results.Date_of_call) Between [Form].[frmEmailAllReports].
'[(txtStartDate= '00/00/0000')] And [Form].[frmEmailAllReports].[(txtEndDate= '00/00/0000')]));
'.......: "qryMystCallbyFPGClinicOverallEmailAll" SELECT * From Results WHERE (((Results.Date_of_call) Between [FORM]![frmEmailAllReports]![StartDate] And
'[FORM]![frmEmailAllReports]![EndDate]));
'.......: "rptMystCallsbyFPGClinicEmailAll_SubReport" = Subreport to calculate % correct for ALl FPG Calls Correct
'.......: "rptMystCallsbyClinicEmailAll_Subreport" = SubReport to calculate Clinic level % correct
'.......: "rptMystCall_CallDetail_EmailAllSubReport" = Subreport to provide call details
'.......: "rptCallResultsPerClinic_EmailAll" = Main Report includes above three SubReports
'==============================================================================================================================
Option Compare Database
Option Explicit
Private Const strPath As String = "F:\temp\"
Dim AttachmentName As String
Public Function SendEMail()
On Error Resume Next
Dim db As DAO.Database
Dim MailList As DAO.Recordset
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim Subjectline As String
Dim BodyFile As String
Dim fso As FileSystemObject
Dim MyBody As TextStream
Dim MyBodyText As String
Dim MyNewBodyText As String
Dim strSQL As String
Dim strQueryName As String
Dim qryDef As QueryDef
Dim StartDate As Date
Dim EndDate As Date
'==================================================================================
Set fso = New FileSystemObject
' Populate Subject Line
Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
"Mystery Caller Survey Email All Reports!")
' If there's no subject, end Process.
If Subjectline$ = "" Then
MsgBox "No subject line, no message." & vbNewLine & vbNewLine & _
"Quitting...", vbCritical, "E-Mail Merger"
Exit Function
End If
' Populate Body Text
BodyFile$ = "F:\My UCLA Items\Mystery Caller\MystCallEmailScript.txt"
' If there's nothing to say, end process.
If BodyFile$ = "" Then
MsgBox "No body, no message." & vbNewLine & vbNewLine & _
"Quitting...", vbCritical, "No Message!"
Exit Function
End If
' Check to make sure the file exists...
If fso.FileExists(BodyFile$) = False Then
MsgBox "The body file isn't where you say it is. " & vbNewLine & vbNewLine & _
"Quitting...", vbCritical, "No message!"
Exit Function
End If
' Since we got a file, we can open it up.
Set MyBody = fso.OpenTextFile(BodyFile, ForReading, False, TristateUseDefault)
' and read it into a variable.
MyBodyText = MyBody.ReadAll
' and close the file.
MyBody.Close
' Now, open Outlook for our own device..
Set MyOutlook = New Outlook.Application
'====================================================================================
' Set up the database and query connections
'set variable values
Set db = CurrentDb
strQueryName = "qryMyEmailAddresses"
'
'Notice below how we inserted the variable as a parameter value - Visual Basic will evaluate strMonth and insert the value for us.
strSQL = "SELECT Results.Clinic_Name, Results.Date_of_Call FROM Results WHERE (((Results.Clinic_Name)=[Form]![frmEmailAllReports]![Clinic_Name])" _
& "((Results.Date_of_call) Between [FORM]![frmEmailAllReports]![StartDate] And [FORM]![frmEmailAllReports]![EndDate])); LIKE '" & StartDate & EndDate & "';"
'Create query definition
Set qryDef = db.CreateQueryDef(strQueryName, strSQL)
Set MailList = db.OpenRecordset("Contacts1")
' Loop through the list of email addresses FROM Contacts1,
' adding them to e-mails and sending them.
Do Until MailList.EOF
' This creates the e-mail
Set MyMail = MyOutlook.CreateItem(olMailItem)
' This addresses it
MyMail.To = MailList("email")
'This gives it a subject
MyMail.Subject = Subjectline$
'========================================================
'This line will copy the "master" template into
'a variable we can mess around with
MyNewBodyText = MyBodyText
MyNewBodyText = Replace(MyNewBodyText, "[[Contact_First]]", MailList("Contact_First"))
'This gives it the body
MyMail.Body = "Dear" & " " & MailList("Contact_First") & "," & MyNewBodyText
'============================================================
AttachmentName = MailList("Clinic_Name") & ".pdf"
' Setup Attachment Print to PDF
DoCmd.OutputTo acOutputReport, "rptCallResultsPerClinic_EmailAll", "PDFFormat(*.PDF)", strPath & AttachmentName, True, "", , acExportQualityScreen
'This sends it!
MyMail.Attachments.Add strPath & AttachmentName, olByValue, 1, AttachmentName
MyMail.Save
'And on to the next one...
MailList.MoveNext
Loop
Set MyMail = Nothing
'MyOutlook.Quit
Set MyOutlook = Nothing
MailList.Close
Set MailList = Nothing
db.Close
Set db = Nothing
End Function