Macro to send birthday reminder via outlook email

Hi,

Please help to create a macro to send birthday reminder via outlook email if the date and month equals system date and month. Macro to execute every time the workbook is opened and look for the date and send reminder email to [email protected] mailid.

Hi Vijay,

Your birthday is 24-Oct-79.

___________________________
Please help!

Vijay

Thank you. This is sending email only to the last occurance. It is send email only for Anand birthdate is today. However the email is not displayed for Vijay

I change the code to .send and changed the date to today's. I received one email for Name Vijay, I am not receiving email for Anand with today's date.

This works for me...

Sub workbook_open()

Dim myRange As Range
Dim firstDate As Date
Dim datechk As Date

datechk = DateValue(Now)

If (Sheet2.Cells(1, 2)) < DateValue(Now) Then 'to avoid running macro more than once a day

todaysdate = DateValue(Now) 'GET TODAYS DATE
futuredate = DateValue(Now) + 20
Set myRange = Worksheets("sheet1").Range("C5:C40")'number of the members in the bthday list
For Each c In myRange 'SET RANGE HERE I.E. COLUMN TO COMPAIR TO

If c.Value >= todaysdate And c.Value <= futuredate Then
Dim name As String
Dim msg As String
name = Right(c.Address, 2) 'it will work only upto 100 rows in C column
Dim verb As String
verb = "'s birhtday is on "
msg = (Worksheets("sheet1").Cells(name, "B") & verb & c.Value)
Sheet2.Cells(1, 2) = datechk
bthdayreminder (msg)
End If
Next c
End If

End Sub



Sub bthdayreminder(msg)
'Working in 2000-2010

Dim OutApp As Object
Dim OutMail As Object
Dim Fname As String
Dim emailRng As Range, cl As Range
Dim sTo As String

Set emailRng = Worksheets("sheet3").Range("A2:A4") 'for multiple recipients

For Each cl In emailRng
sTo = sTo & ";" & cl.Value
Next

sTo = Mid(sTo, 2)
'Turn on Outlook for Excel
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Dim myRange As Range
Dim firstDate As Date

With OutMail
.to = sTo
.CC = ""
.BCC = ""
.Subject = "Birthday Reminder"
'replace x with <
s = s & "<p><font face=""Monotype Corsiva"" size=""4"" "
s = "Hi Team, <br> "
s = s & "<br><b>" & msg & "</b><br>"
s = s & "<br> Thanks & Regards, <br> " & "xxx"

.HTMLBody = s
.Send 'or use
'Display
End With

Set OutMail = Nothing
Set OutApp = Nothing


End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ThisWorkbook.Save'automatically saving the Workbook
End Sub

HI

I Have a small problem I need an macro to allow me to send yearly induction reminders to my workers via emailYearly Induction 2014.xls but must be limited number at a time e.g 20. I have a small start.

Thank you