Send e-mail automatically "happy birthday"

JorgenKjer

Board Regular
Joined
Aug 1, 2016
Messages
65
Office Version
  1. 2013
Platform
  1. Windows
Hi

I seek help to solve this problem
I have a list of members in a Dynamic Range, I would like the board members,there are five, to
automatically receive an e-mail on the day when one of the members has abirthday. Names of the members are in column B and birthday in column M.
The e-mail must be limited to a short text<o:p></o:p>

"Remember XXXXXXXXX's birthday dd-mmm"<o:p></o:p>
I hope there is someone who has a suggestion to solve the problem.<o:p></o:p>
<o:p> </o:p>
Kind regards<o:p></o:p>
Jorgen<o:p></o:p>
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Hi

The checking will take place every time you activate that sheet:

Code:
' sheet module
Private Sub Worksheet_Activate()
Dim i%
For i = 1 To Range("b" & Rows.Count).End(xlUp).Row
    If Day(Now()) = Day(Cells(i, "m")) And Month(Now()) = Month(Cells(i, "m")) _
    Then send_mail i
Next
End Sub


Sub send_mail(r%)
Dim outapp As Outlook.Application, outmail As MailItem
Set outapp = CreateObject("Outlook.application")
Set outmail = outapp.CreateItem(olMailItem)
With outmail
    .To = Cells(r, "c")
    .cc = Cells(r, "d")
    .BCC = Cells(r, "e")
    .Subject = "Birthday"
    .Body = "Remember " & Cells(r, "b") & "'s birthday: " & _
    Format(Cells(r, "m"), "dd-mmm")
'    .Send
    .Display
End With
Set outmail = Nothing
Set outapp = Nothing
End Sub
 
Upvote 0
I was once asked how to do this with a Lotus Notes email service. Thankfully I was able to avoid the issue.

Anybody ever tried to make this work when using other email systems (including Hotmail or Gmail)?
 
Upvote 0
Actually... I have a process that analyses Operating Theatre lists and sends emails to various people based on conditions found.
The "Working" email bit is:
Code:
Public Function MailTextOutlook(sTo As String, sSubject As String, sBody As String, _
    Optional sCC As String, Optional sBCC As String, _
    Optional priority As OlImportance = olImportanceNormal, _
    Optional dtmExpire As Date, _
    Optional emailFlag As OlFlagIcon = olNoFlagIcon) As Boolean
'For Tips see: [URL]http://www.rondebruin.nl/win/winmail/Outlook/tips.htm[/URL]
'Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    If dtmExpire = 0 Then dtmExpire = DateAdd("d", 1, Now())
    MailTextOutlook = False
    On Error GoTo MailFailed
    With OutMail
        .To = sTo
        .CC = sCC
        .BCC = sBCC
        .Subject = sSubject
        If IsHTMLMail Then
            .HTMLbody = sBody
        Else
            .Body = sBody
        End If
        .Importance = priority
        .FlagIcon = emailFlag
        'You can add a file like this
        '.Attachments.Add ("C:\test.txt")
        .DeleteAfterSubmit = True
        .ExpiryTime = dtmExpire
        .Send   'or use .Display
    End With
    MailTextOutlook = True
MailFailed:
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Function
Things that you might find interesting in here are:
- The .To, .CC and .Bcc all take standard email entries, including concatenated email addresses (using semi-colon), groups and Gmail/Hotmail addresses
- You can expire emails. It actually works and puts a strikethrough once expired (though not sure what it does on Gmail or Hotmail)
- If you want to be crazy and create HTML code as your "Birthday" text, then you can send a html message
- DeleteAfterSubmit means that you DO NOT have it in your Sent box.
 
Upvote 0
hello.....
i want your help regarding my dissertation work doing programming in macro. i want colour in 15 to 20 and then 36 to 41 and then same it should be repeat from 15 to 4199.please do needful

for i = 15 to 4199 step 21
cells(i,2).interior.colorindex = 6
next i
 
Upvote 0
Hey Worf<o:p></o:p>
Thank youfor your prompt reply, the code works, I just had to adjust it a little to fit myRange.<o:p></o:p>
However, Ihave yet another challenge. The five board members who receive the mail to reminderthem of a member's birthday is themselves on the members list and do not need toreceive an email when they themselves have a birthday, but the rest of the board members need a reminder<o:p></o:p>
I hope thismages sense

Private Sub Worksheet_Activate()
Dim i%
For i = 6 To Range("b" & Rows.Count).End(xlUp).Row
If Day(Now()) = Day(Cells(i, 13)) And Month(Now()) = Month(Cells(i, 13)) Then
send_mail i
End If
Next
End Sub


Sub send_mail(r%)
Dim outapp As Outlook.Application, outmail As MailItem
Set outapp = CreateObject("Outlook.application")
Set outmail = outapp.CreateItem(olMailItem)
With outmail
.To = "board members_1;board members_2;board members_3;board members_4;board members_5"
'Cells(r, Cells(r, 9).Value)
'.cc = Cells(r, "d")
'.BCC = Cells(r, "e")
.Subject = "Birthday"
.Body = "Remember " & Cells(r, 2).Value & "'s birthday: " & _
Format(Cells(r, 13), "dd-mmm")
'.Send
.Display
End With
Set outmail = Nothing
Set outapp = Nothing


End Sub
 
Upvote 0
New version:

Code:
Private Sub Worksheet_Activate()
Dim i%
For i = 6 To Range("b" & Rows.Count).End(xlUp).Row
    If Day(Now()) = Day(Cells(i, 13)) And Month(Now()) = Month(Cells(i, 13)) _
    Then send_mail i
Next
End Sub


Sub send_mail(r%)
Dim outapp As Outlook.Application, outmail As MailItem, tolist$, i%
Set outapp = CreateObject("Outlook.application")
Set outmail = outapp.CreateItem(olMailItem)
tolist = ""
For i = 6 To Range("b" & Rows.Count).End(xlUp).Row
    If i <> r Then tolist = tolist & Cells(i, "c") & ";"    ' emails at column C
Next
With outmail
.To = tolist
.Subject = "Birthday"
.Body = "Remember " & Cells(r, 2) & "'s birthday: " & _
Format(Cells(r, 13), "dd-mmm")
.Display
End With
Set outmail = Nothing
Set outapp = Nothing
End Sub
 
Upvote 0
Hello mmaan

If you have a request that is not directly related to the thread’s subject, please start a new one.

Code:
Sub Colours()
Const maxrow As Long = 100
Dim i%
For i = 15 To maxrow Step 21
    Cells(i, 2).Resize(6).Interior.ColorIndex = 6
Next
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,275
Messages
6,171,121
Members
452,381
Latest member
Nova88

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top