PDA

View Full Version : Send email notification when conditions are met



andytpl
07-08-2008, 10:52 PM
I have workbook that record the incoming letters. Each of these letter need to be responded to within 60 days from the date of receipt. The data are startingin row 6 and in Col D is the date of receipt and Col E is to record the date of reply. I need to be able to run a macro which perform the following task.

1. If Col E is blank or 30 days or 40 days or 50 days or 60 days past the date or receipt, send out a email message to an email address in Col G; cc mail to email address in Col H.
2. Once the email is sent in Col I the date sent is automatically keyed in.
3. This macro should not be repeated within 48 hours from the last opening of this workbook.
4. The message of the email should contain the following sentences.
"You have not response to the letter in the Letter Register. Please response within the next 2 days. The letter reference is in Col B

I would appreciate any help with this request.

andytpl
07-11-2008, 12:33 AM
I have found the solution to my question and here are the codes. The solution was provided in large part by Ron de Bruin.
What this macro does is to check the worksheet and send out an email whenever the following conditions are met. It must be more than 45 days after the receipt of the letter; it has not be responded to and no email reminder has been sent before.

Sub Send_Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Lastcell As String
Dim rng As Range


Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

Lastcell = Range("E65536").End(xlUp).Address
Set rng = Range("E8:" & Lastcell)
For Each cell In rng
On Error GoTo cleanup
If DateDiff("d", cell, Now) > 45 And LCase(cell.Offset(0, 1).Value) = "" And LCase(cell.Offset(0, 2).Value) = "" Then

Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = Range("H8").Value
.CC = Range("I8").Value
.Subject = "Infrastructure Section Claim Register"
.Body = "Dear " & cell.Offset(0, 5).Value & vbNewLine & vbNewLine & _
"From the Claim Register Record, it appears that we did not response to " & cell.Offset(0, -3).Value & "'s Claim Notification as detailed in their letter ref., " & cell.Offset(0, -1).Value & " for more than 45 days." & vbNewLine & vbNewLine & _
"Please follow up before the 60 days time period as required in the CoC."
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Send
End With

On Error GoTo 0


cell.Offset(0, 2).Value = "Send"
Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True

End Sub