' Automate the routine to send notifications of Payments and deposits for clients
Dim strLastCell 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 iLastRow As Integer, iColon As Integer
Dim blnDisplayMsg As Boolean
Dim rngCell As Range
' 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
' Create the Outlook session.
Set objOutlook = GetObject(, "Outlook.Application")
'Set objOutlook = New Outlook.Application
' I get my data here
' Now populate the outlook fields
' Create the message.
'Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set objOutlookMsg = objOutlook.CreateItemFromTemplate(strTemplatePath & "\SSAFA Email.oft")
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("* - 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
' End If
' Now get the next record
' ActiveCell.Offset(1, 0).Select
Debug.Print rngCell
' Loop
Next rngCell
' Switch off the filter
ActiveSheet.AutoFilterMode = False
ActiveWorkbook.Save
Proc_Exit:
Exit Sub
Err_Handler:
MsgBox Err.Number & " " & Err.Description
Resume Proc_Exit
End Sub
