Private Sub cmdEmail_Click()
' 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
' Create the message if first time we are in a different client or tran type.
'Set objOutlookMsg = objOutlook.CreateItemFromTemplate(strTemplatePath & "\SSAFA Email.oft")
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("SSAFA West Glamorgan Branch")
Set objOutlookRecip = .Recipients.Add("South West Wales SSAFA")
objOutlookRecip.Type = olTo
intAccount = 3
End If
' Need to send using SSAFA 365 int = 15
'intAccount = 15
' Add the CC recipient(s) to the message.
If rs!CCOffice And rs!ClientDivision = "SSW" Then
' Set objOutlookRecip = .Recipients.Add("SSAFA West Glamorgan Branch")
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 & "<table border = '0' cellpadding = '5' cellspacing = '5'>"
' .HTMLBody = .HTMLBody & "<td>" & "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 = "<font color=""Red"">" & strBalance & "</font>"
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 & "</table>" & 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
' Switch off the filter and release recordset object, and go back to record we were on
' Me.FilterOn = False
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