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
Dim strDate 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, strNotes As String
Dim iColon As Integer
Dim lngCurrentRec As Long
Dim blnDisplayMsg As Boolean
Dim db As Database
Dim rs As DAO.Recordset, rsCW As DAO.Recordset
' 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>"
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, "<BODY>")
strHeader = Left(strSignature, intBody + 5)
strFooter = Mid(strSignature, intBody + 6)
End If
' See if Outlook is open, otherwise open it
If fIsOutlookRunning = False Then
Call OpenOutlook
DoEvents
End If
' 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 set the filter to get just the rows we want
strFilter = "Yes"
Me.Filter = "EmailStatus = """ & strFilter & """"
Me.FilterOn = True
' Make sure we save any changed data and then get recordset
If Me.Dirty Then Me.Dirty = False
Set rs = Me.RecordsetClone
rs.MoveFirst
' Now walk through each record
Do While Not rs.EOF
' MsgBox rs!ID
strDate = rs!TransactionDate
strType = rs!TranType
strClient = rs!Client
str3rdParty = rs!ThirdParty
strAmount = Format(rs!Amount, "Currency")
strRef = rs!Reference
strMethod = rs!Method
' 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
strNotes = Nz(rs!Notes, "")
' Update the record
rs.Edit
rs!EmailStatus = "Sent"
'rs.EmailStatus = "Sent"
rs!EmailDate = Date
rs.Update
' Now populate the outlook fields
' Create the message.
'Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
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.
Set objOutlookRecip = .Recipients.Add("** SSAFA West Glamorgan Branch")
objOutlookRecip.Type = olCC
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
strDatetype = "Date "
If strType = "Payment" Then
.Subject = " Payment Made - " & strClient
str3rdPartyType = "Recipient: "
strDatetype = strDatetype & "Paid: "
Else
.Subject = "Deposit Received - " & strClient
str3rdPartyType = "Received From: "
strDatetype = strDatetype & "Received: "
End If
' Now build the body of the message
' Make sure we have a colon in client, else use whole field
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
.HTMLBody = .HTMLBody & strPad & str3rdPartyType & strPadCol & str3rdParty & strEndPad
.HTMLBody = .HTMLBody & strPad & strDatetype & strPadCol & strDate & strEndPad
.HTMLBody = .HTMLBody & strPad & "Payment Method: " & strPadCol & strMethod & strEndPad
.HTMLBody = .HTMLBody & strPad & "Reference: " & strPadCol & strRef & strEndPad
.HTMLBody = .HTMLBody & strPad & "Payment Amount: " & strPadCol & strAmount & strEndPad
' Add any notes if they exist
If Len(strNotes) > 0 Then
.HTMLBody = .HTMLBody & strPad & "Notes: " & strPadCol & strNotes & strEndPad
End If
.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?
If blnDisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
' Now get the next record
rs.MoveNext
Loop
' Switch off the filter and release recordset object, and go back to record we were on
Me.FilterOn = False
DoCmd.GoToRecord , , acGoTo, lngCurrentRec
Proc_Exit:
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
Set objOutlookRecip = Nothing
Set objOutlookAttach = Nothing
Set rs = Nothing
Set rsCW = Nothing
Set db = Nothing
Exit Sub
Err_Handler:
MsgBox Err.Number & " " & Err.Description
Resume Proc_Exit
End Sub
Public Sub OpenOutlook()
'Depending on your version of Access, Access.hWndAccessApp could also be Application.hWnd
If ShellExecute(Access.hWndAccessApp, vbNullString, "Outlook", vbNullString, "C:\", 1) < 33 Then
MsgBox "Outlook not found."
End If
End Sub
