Private Sub cmdEmail_Click() On Error GoTo Err_Handler ' Automate the routine to send notifications of Payments and deposits for clients Dim strFilter As String, strClientType As String Dim strDate As String, strSQLEmail As String Dim strType As String, strClient As String, str3rdID As String, str3rdParty As String, str3rdPartyType As String, strAmount As String, strRef As String, strMethod As String Dim strCaseWorker As String, strDatetype As String, strPad As String, strEndPad As String, strPadCol As String, strBlankLine As String, strNotes As String Dim strBalance As String, dblBalance As Double Dim iColon As Integer, intTransactions As Integer Dim lngCurrentRec As Long Dim blnDisplayMsg As Boolean, blnSameEmail As Boolean Dim db As Database Dim rs As DAO.Recordset, rsCW As DAO.Recordset Dim blnSameClientType As Boolean ' Now the Outlook variables Dim objOutlook As Outlook.Application Dim objOutlookMsg As Outlook.MailItem Dim objOutlookRecip As Outlook.Recipient Dim objOutlookAttach As Outlook.Attachment Dim strSigPath As String, strSignature As String, strAttachFile As String Dim strHeader As String, strFooter As String, strBody As String, strTemplatePath As String, strAppdata As String Dim intBody As Integer, intAccount As Integer ' Set up HTML tags strPad = "" strEndPad = "" strPadCol = "" strBlankLine = "" On Error GoTo Err_Handler 'Establish all the static Outlook Data ' Get appdata path strAppdata = Environ("Appdata") ' Set paths strTemplatePath = strAppdata & "\Microsoft\Templates" strSigPath = strAppdata & "\Microsoft\Signatures\Ssafa.htm" 'Get the signature if it exists If Dir(strSigPath) <> "" Then strSignature = GetBoiler(strSigPath) intBody = InStr(strSignature, "
") 'intBody = InStr(strSignature, "") strHeader = Left(strSignature, intBody + 24) ' 5 strFooter = Mid(strSignature, intBody + 24) ' 6 End If ' See if Outlook is open, otherwise open it 'If fIsOutlookRunning = False Then Set objOutlook = CreateObject("Outlook.Application") 'Call OpenOutlook 'Pause (5) ' Else 'Set objOutlook = GetObject(, "Outlook.Application") 'End If ' Make sure we save any changed data and then get recordset If Me.Dirty Then Me.Dirty = False ' Update the status bar SetStatusBar ("Collecting records.....") strSQLEmail = "SELECT Format([TransactionDate],""yyyymmdd"") & Format([ID],""000000"") AS UKey, Emails.*, tblClient.ClientDivision From Emails " strSQLEmail = strSQLEmail & "LEFT JOIN tblClient ON Emails.CMS = tblClient.ClientCMS " strSQLEmail = strSQLEmail & "WHERE (((Emails.EmailStatus) = 'Yes')) " ' AND (Emails.DelayEmail = False)) " 'strSQLEmail = strSQLEmail & "ORDER BY Emails.Client, Emails.TranType, Emails.ID, Emails.TransactionDate;" strSQLEmail = strSQLEmail & "ORDER BY Emails.Client, Emails.TranType, Format([TransactionDate],""yyyymmdd"") & Format([ID],""000000"") ;" ' Create the Outlook session. 'Set objOutlook = GetObject(, "Outlook.Application") 'Set objOutlook = New Outlook.Application ' Open lookup table for Email CC Name (normally a Case Worker) Set db = CurrentDb Set rsCW = db.OpenRecordset("SELECT * from Lookups WHERE DataType = 'Email' AND DeActiveDate IS NULL") ' Save the current record position lngCurrentRec = Me.CurrentRecord ' Now get the data for the emails Set rs = db.OpenRecordset(strSQLEmail) ' Check we have some records to process If rs.RecordCount = 0 Then MsgBox "No records to process?", vbOKOnly, "Send Emails" Exit Sub End If ' OK, we are good so send the emails. ' Decide whether to display or just send emails blnDisplayMsg = Me.chkDisplay rs.MoveFirst SetStatusBar ("Creating Emails.....") ' Now walk through each record Do While Not rs.EOF ' Set flag and field to check blnSameClientType = True strClientType = rs!Client & rs!TranType strType = rs!TranType ' Create the message if first time we are in a different client or tran type. Set objOutlookMsg = objOutlook.CreateItemFromTemplate(strTemplatePath & "\SSAFA Email.oft") With objOutlookMsg ' Set the category .Categories = "SSAFA" .Importance = olImportanceHigh ' Add the To recipient(s) to the message. (Also work out which account to send on 12/07/19) If rs!ClientDivision = "SSW" Then Set objOutlookRecip = .Recipients.Add("Jim Needs - Personal") objOutlookRecip.Type = olTo intAccount = 2 Else Set objOutlookRecip = .Recipients.Add("South West Wales SSAFA") objOutlookRecip.Type = olTo intAccount = 3 End If ' Add the CC recipient(s) to the message. If rs!CCOffice And rs!ClientDivision = "SSW" Then Set objOutlookRecip = .Recipients.Add("South West Wales SSAFA") objOutlookRecip.Type = olCC End If ' Need to get the Case Worker name from table, might be deactivated, so not in recordset If rs!CaseWorker > 0 Then rsCW.FindFirst "[ID] = " & rs!CaseWorker If rsCW.NoMatch Then strCaseWorker = "" Else strCaseWorker = rsCW!Data End If Else strCaseWorker = "" End If If strCaseWorker <> "" Then Set objOutlookRecip = .Recipients.Add(strCaseWorker) objOutlookRecip.Type = olCC End If ' Add Glyn in as BCC for CMS update - 12/02/19 ' Only if SSW and he is not the caseworker If rs!ClientDivision = "SSW" And strCaseWorker <> "Glyn Davies" Then Set objOutlookRecip = .Recipients.Add("Glyn Davies") objOutlookRecip.Type = olBCC End If ' Set the Format, Subject, Body, and Importance of the message. '.BodyFormat = olFormatHTML strClient = rs!Client If strType = "Payment" Then .Subject = " Payment Made - " & strClient Else .Subject = "Deposit Received - " & strClient End If ' Now start the email with header 'iColon = InStr(strClient, ":") ' If iColon = 0 Then iColon = Len(strClient) + 1 .HTMLBody = strHeader & "" ' .HTMLBody = .HTMLBody & "
" & "Client: " & strPadCol & Left(strClient, iColon - 1) & strEndPad 'End If ' Set counter to zero for count of transactions intTransactions = 0 End With Do While blnSameClientType strDate = rs!TransactionDate strType = rs!TranType str3rdParty = rs!ThirdParty strAmount = Format(rs!Amount, "Currency") 'strBalance = Format(rs!Balance, "Currency") 'strBalance = Format(DSum("Amount", "Emails", "CMS = " & rs!CMS & " AND ID <= " & rs!ID), "Currency") ' Now using unique key Ukey to get correct running balance for entries out of sequence dblBalance = DSum("Amount", "Emails", "CMS = " & rs!CMS & " AND format(TransactionDate,'yyyymmdd')& format(ID,'000000') <= '" & rs!Ukey & "'") strBalance = Format(dblBalance, "Currency") ' Missed in sequence dates was producing erroneous balances 240620 'strBalance = Format(Nz(DSum("Amount", "Emails", "CMS = " & [CMS] & " AND ID <=" & [ID]), 0), "Currency") 'Now Calculated on the fly 'strBalance = Format(rs!Balance, "Currency") ' was Format(DSum("[Amount]", "Emails", "[CMS]=" & rs!CMS & " AND ID <= " & rs!ID), "Currency") ' Make strBalance Red if negative If dblBalance < 0 Then strBalance = "" & strBalance & "" End If strRef = rs!Reference strMethod = rs!Method 'strDatetype = "Date " If strType = "Payment" Then str3rdPartyType = "Recipient:" strDatetype = "Date Paid:" Else str3rdPartyType = "From Donor:" strDatetype = "Received:" End If strNotes = Nz(rs!Notes, "") ' Now build the body of the message ' Make sure we have a colon in client, else use whole field ' Now add the variable data With objOutlookMsg .HTMLBody = .HTMLBody & strPad & str3rdPartyType & strPadCol & str3rdParty & strEndPad .HTMLBody = .HTMLBody & strPad & strDatetype & strPadCol & strDate & strEndPad .HTMLBody = .HTMLBody & strPad & "Method:" & strPadCol & strMethod & strEndPad .HTMLBody = .HTMLBody & strPad & "Reference:" & strPadCol & strRef & strEndPad .HTMLBody = .HTMLBody & strPad & "Amount:" & strPadCol & strAmount & strEndPad .HTMLBody = .HTMLBody & strPad & "Balance:" & strPadCol & strBalance & strEndPad ' Add any notes if they exist If Len(strNotes) > 0 Then .HTMLBody = .HTMLBody & strPad & "Notes:" & strPadCol & strNotes & strEndPad End If ' ' Add blank line for next set .HTMLBody = .HTMLBody & strBlankLine & strBlankLine End With 'Now update the record rs.Edit rs!EmailStatus = "Sent" rs!EmailDate = Date rs.Update ' Now get next record rs.MoveNext ' Has client or tran type changed? If Not rs.EOF Then If strClientType = rs!Client & rs!TranType Then blnSameClientType = True Else blnSameClientType = False End If Else blnSameClientType = False End If ' Increment the counter intTransactions = intTransactions + 1 Loop ' End blnClientType loop ' Now add the footer and amend subject to indicate how many transactions in email With objOutlookMsg .Subject = .Subject & " - " & intTransactions & " " & strType If intTransactions > 1 Then .Subject = .Subject & "s" End If ' Need to amend the footer depending on account being used intAccount = 2 = SSW, 3 is NPT If intAccount = 3 Then strFooter = Replace(strFooter, "Divisional Treasurer, Swansea South & West", "Temporary Divisional Treasurer, Neath & Port Talbot") End If ' Now add the footer .HTMLBody = .HTMLBody & "
" & strFooter '.Importance = olImportanceHigh 'High importance 'Debug.Print strHeader 'Debug.Print .htmlbody 'Debug.Print strFooter ' Resolve each Recipient's name. For Each objOutlookRecip In .Recipients 'Debug.Print objOutlookRecip.Name objOutlookRecip.Resolve Next ' Should we display the message before sending? .SendUsingAccount = objOutlook.Session.Accounts.Item(intAccount) If blnDisplayMsg Then .Display Else .Save .Send End If End With Loop SetStatusBar ("Emails created.....") DoCmd.GoToRecord , , acGoTo, lngCurrentRec cmdRequery_Click Proc_Exit: Set objOutlook = Nothing Set objOutlookMsg = Nothing Set objOutlookRecip = Nothing Set objOutlookAttach = Nothing Set rs = Nothing Set rsCW = Nothing Set db = Nothing SetStatusBar (" ") Exit Sub Err_Handler: MsgBox Err.Number & " " & Err.Description Resume Proc_Exit End Sub