Code:
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 = "<tr><td>"
strEndPad = "</td></tr>"
strPadCol = "</td><td>"
strBlankLine = "<tr></tr>"
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, "<div class=WordSection1>")
'intBody = InStr(strSignature, "<BODY>")
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)
' Now set the filter to get just the rows we want
' strFilter = "Yes"
' Me.Filter = "EmailStatus = """ & strFilter & """"
'Me.FilterOn = True
' 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
'Set rs = Me.RecordsetClone
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")
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
Novice
Windows 11 
Access 2016
VIP
Originally Posted by Micron
Report with subreport generates a page break after each main report record. Room for 2 records/page
Posting Permissions
Reply With Quote
