Macro to send birthday reminder via outlook email

[vijanand1279]

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 vijay1279@rediffmail.com mailid.

Hi Vijay,

Your birthday is 24-Oct-79.

___________________________
Please help!

Vijay

[humdingaling]

Private Sub Workbook_Open()

    
    Dim i As Long
    Dim OutApp, OutMail As Object
    Dim strto, strsub, strbody As String
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    
    
    For i = 2 To Range("b65536").End(xlUp).Row
        
        If Day(Cells(i, 2).Value) & Month(Cells(i, 2).Value) = Day(Now()) & Month(Now()) Then
            
            strto = "vijay1279@rediffmail.com" 'email address
            strsub = "Happy Birthday " & Cells(i, 1).Value
            strbody = "Hi " & Cells(i, 1).Value & "," & vbNewLine & vbNewLine & _
                    "Your birthday is " & Cells(i, 2).Value
            With OutMail
                .To = strto
                .Subject = strsub
                .Body = strbody
                '.Send
                .display
                                
            End With
        End If
    Next
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

take the ' away from send to make it automatically send.

you may want to add like a msgbox or something to prompt if email was/is going to be sent

[vijanand1279]

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

[humdingaling]

the display part happens once because it overwrites previously display
however this does not mean it does not send
take the ' away from send to make it automatically send.

if you wish to preview it
put a break on .display

[vijanand1279]

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.

[humdingaling]

sorry put the set outside the loop
try this

Private Sub Workbook_Open()
    Dim i As Long
    Dim OutApp, OutMail As Object
    Dim strto, strcc, strbcc, strsub, strbody As String
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
       
    For i = 2 To Range("b65536").End(xlUp).Row
        Set OutMail = OutApp.CreateItem(0)
        If Day(Cells(i, 2).Value) & Month(Cells(i, 2).Value) = Day(Now()) & Month(Now()) Then
            
            strto = "vijay1279@rediffmail.com" 'email address
            strsub = "Happy Birthday " & Cells(i, 1).Value
            strbody = "Hi " & Cells(i, 1).Value & "," & vbNewLine & vbNewLine & _
                    "Your birthday is " & Cells(i, 2).Value
            With OutMail
                .To = strto
                .Subject = strsub
                .Body = strbody
                .Send
                '.display
                                
            End With
            On Error Resume Next
        End If
    Next
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

also put on error statement

[dinesh21]

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

[tdmoodley]

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