Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!
Private Sub EmailWorkbook_Click() DoCmd.SetWarnings False Dim TblEmailPayments As Recordset Dim strSql As String Dim EmailAddress As String Dim Contact As String Dim Attachment As String Dim FirstName As String Dim FileName As String Dim mess_body As String Dim appOutLook As Outlook.Application Dim MailOutLook As Outlook.MailItem Set appOutLook = CreateObject("Outlook.Application") Set MailOutLook = appOutLook.CreateItem(olMailItem) Dim ContactEM As String Dim FirstnameC As String Dim SourceTable As String Set db = CurrentDb Set rstTables = db.OpenRecordset("TblEmailPayments") Dim oApp, unzipfile, pathname, location rstTables.MoveFirst Do While Not rstTables.EOF DoCmd.OpenQuery "QdelTblEmailPayTemp", acViewNormal, acEdit strSql = "INSERT INTO TblEmailPayTemp([Contact],[EmailAddress],[FirstName], [Attachment])" & _ "SELECT TblEmailPayments.Contact, TblEmailPayments.EmailAddress, TblEmailPayments.FirstName, TblEmailPayments.Attachment FROM TblEmailPayments WHERE TblEmailPayments.Contact = " & Chr$(34) & rstTables.Contact & Chr$(34) & ";" Set oApp = CreateObject("Shell.Application") pathname = "H:\PDF\" DoCmd.RunSQL strSql FirstnameC = DLookup("Firstname", "TblEmailPayTemp") Set appOutLook = CreateObject("Outlook.Application") Set MailOutLook = appOutLook.CreateItem(olMailItem) With MailOutLook .BodyFormat = olFormatHTML .To = DLookup("EmailAddress", "TblEmailPayTemp") .Subject = "Financial Closing Details" .HTMLBody = (FirstnameC) & ", " & "<BR>" & "<BR>" & _ vbLf & "Attached is the detail Financial Closing report. " & "<BR>" & "<BR>" & _ "If you have any questions, please mail " & _ "Mail Stop 01-660" .Attachments.Add pathname & "MasterReport.xls" .Close 0 '0 = olSave End With rstTables.MoveNext Set MailOutLook = Nothing Loop Set oApp = Nothing DoCmd.SetWarnings True Beep MsgBox "The Financial Report was emailed to all Accounts and is in your Drafts folder!!!" End Sub