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
Dim iColon 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
' Set up HTML tags
strPad = "<tr><td>"
strEndPad = "</td></tr><tr></tr>"
strPadCol = "</td><td> </td><td>"
strBlankLine = "<tr></tr><tr></tr><tr></tr><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 Emails.* From Emails "
strSQLEmail = strSQLEmail & "WHERE (((Emails.EmailStatus) = 'Yes')) "
strSQLEmail = strSQLEmail & "ORDER BY Emails.Client, Emails.TranType, Emails.ID, Emails.TransactionDate;"
' 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'")
' 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
' 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.
Set objOutlookRecip = .Recipients.Add("Jim Needs - SSAFA Swansea")
objOutlookRecip.Type = olTo
' Add the CC recipient(s) to the message.
If rs!CCOffice Then
Set objOutlookRecip = .Recipients.Add("** SSAFA West Glamorgan Branch")
objOutlookRecip.Type = olCC
End If
' Need to get the Case Worker name from table'
If rs!CaseWorker > 0 Then
rsCW.FindFirst "[ID] = " & rs!CaseWorker
strCaseWorker = rsCW!Data
Else
strCaseWorker = ""
End If
If strCaseWorker <> "" Then
Set objOutlookRecip = .Recipients.Add(strCaseWorker)
objOutlookRecip.Type = olCC
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><tr>"
' .HTMLBody = .HTMLBody & "<td>" & "Client: " & strPadCol & Left(strClient, iColon - 1) & strEndPad
'End If
End With
Do While blnSameClientType
strDate = rs!TransactionDate
strType = rs!TranType
str3rdParty = rs!ThirdParty
strAmount = Format(rs!Amount, "Currency")
'strBalance = Format(rs!Balance, "Currency")
'Now Calculated on the fly
strBalance = Format(rs!Balance, "Currency") ' was Format(DSum("[Amount]", "Emails", "[CMS]=" & rs!CMS & " AND ID <= " & rs!ID), "Currency")
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
.Body = .Body & PadR(str3rdPartyType, " ", 30) & str3rdParty & vbCrLf
.Body = .Body & PadR(strDatetype, " ", 30) & strDate & vbCrLf
.Body = .Body & PadR("Method:", " ", 30) & strMethod & vbCrLf
.Body = .Body & PadR("Reference:", " ", 28) & strRef & vbCrLf
.Body = .Body & PadR("Amount:", " ", 30) & strAmount & vbCrLf
.Body = .Body & PadR("Balance:", " ", 30) & strBalance & vbCrLf
'.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 & strAmount & strEndPad
' Add any notes if they exist
If Len(strNotes) > 0 Then
'.HTMLBody = .HTMLBody & strPad & PadR("Notes:", ".", 30) & strNotes & strEndPad
.Body = .Body & PadR("Notes: ", " ", 30) & strNotes & vbCrLf
End If
' ' Add blank line for next set
.Body = .Body & vbCrLf
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
Loop ' End blnClientType loop
' Now add the footer
With objOutlookMsg
.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
objOutlookRecip.Resolve
Next
' Should we display the message before sending?
'.SendUsingAccount = objOutlook.Session.Accounts.Item(4)
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
