Automatic Birthday Email and then dismiss the reminder.

[crows]

Hi all,

I'm a first time poster and been struggling with this for a while and hoping to get some advice. As the title says I want to send an automatic email to my contacts who's birthday falls on their birthday which is triggered by a a daily task called Birthday Text as the subject. I have this working with code I found on the net, i.e. the task is triggered and it sends the email. What I want to do though is dismiss the reminder automatically. I have 2 separate VBA codes snippets that both work in isolation i.e. one that sends email via a task and the other that dismisses the notification, however when I try to merge these 2 snippets together I get errors that I cannot debug because I don't have the expertise. Could someone please look at the 2 codes below and assist or point me in the direction on having these working together?....thanks

Send Email via task Snippet

Private Sub Application_Reminder(ByVal Item As Object)
If Item.Subject = "Birthday Text" Then
Dim olkContacts As Outlook.Items, _
olkContact As Object, _
olkMsg As Outlook.MailItem
Set olkContacts = Session.GetDefaultFolder(olFolderContacts).Items
For Each olkContact In olkContacts
If olkContact.Class = olContact Then
If (Month(olkContact.Birthday) = Month(Date)) And (Day(olkContact.Birthday) = Day(Date)) Then
Set olkMsg = Application.CreateItem(olMailItem)
With olkMsg
.Recipients.Add olkContact.Email1Address
'Change the subject as needed'
.Subject = "Happy Birthday " & olkContact.FirstName
'Change the message as needed'
.HTMLBody = "Hi " & olkContact.FirstName & " Happy Birthday"
'Change Display to Send if you want the messages sent automatically'
.Display
End With
End If
End If
Next
Set olkMsg = Nothing
Set olkContact = Nothing
Set olkContacts = Nothing
MsgBox "Sending Birthday Texts, email may seem sluggish for few minutes"
End If
End Sub

Dismiss Task Automatically

' declare this object withEvents displaying all the events
Private WithEvents olRemind As Outlook.Reminders
Private Sub Application_Reminder(ByVal Item As Object)
Set olRemind = Outlook.Reminders
End Sub


Private Sub olRemind_BeforeReminderShow(Cancel As Boolean)


For Each objRem In olRemind
If objRem.Caption = "Birthday Text" Then
If objRem.IsVisible Then
objRem.Dismiss
Cancel = True
End If
Exit For
End If
Next objRem


End Sub

[skatonni]

Private Sub Application_Reminder(ByVal Item As Object) should appear once.

Take the Set olRemind = Outlook.Reminders from the second and put it in the first

Delete the second entirely.

[crows]

Private Sub Application_Reminder(ByVal Item As Object) should appear once.

Take the Set olRemind = Outlook.Reminders from the second and put it in the first

Delete the second entirely.

Hi I really appreciate your reply, I tried that but I get a compile error highlighted in bold...(Invalid attribute in Sub or Function)

Thanks

Private Sub Application_Reminder(ByVal Item As Object)
Set olRemind = Outlook.Reminders
If Item.Subject = "Birthday Text" Then
Dim olkContacts As Outlook.Items, _
olkContact As Object, _
olkMsg As Outlook.MailItem
Set olkContacts = Session.GetDefaultFolder(olFolderContacts).Items
For Each olkContact In olkContacts
If olkContact.Class = olContact Then
If (Month(olkContact.Birthday) = Month(Date)) And (Day(olkContact.Birthday) = Day(Date)) Then
Set olkMsg = Application.CreateItem(olMailItem)
With olkMsg
.Recipients.Add olkContact.Email1Address
'Change the subject as needed'
.Subject = "Happy Birthday " & olkContact.FirstName
'Change the message as needed'
.HTMLBody = "Hi " & olkContact.FirstName & " Happy Birthday"
'Change Display to Send if you want the messages sent automatically'
.Display
End With
End If
End If
Next
Set olkMsg = Nothing
Set olkContact = Nothing
Set olkContacts = Nothing
MsgBox "Sending Birthday Texts, email may seem sluggish for few minutes"
End If
End Sub


' declare this object withEvents displaying all the events
Private WithEvents olRemind As Outlook.Reminders
End Sub


Private Sub olRemind_BeforeReminderShow(Cancel As Boolean)
For Each objRem In olRemind
If objRem.Caption = "Birthday Text" Then
If objRem.IsVisible Then
objRem.Dismiss
Cancel = True
End If
Exit For
End If
Next objRem




End Sub

[skatonni]

End Sub on this to be deleted.

' declare this object withEvents displaying all the events
Private WithEvents olRemind As Outlook.Reminders
End Sub

As well in case this is located as shown here move Private WithEvents olRemind As Outlook.Reminders to the top of the module after Option Explicit

[crows]

Hi again,

I'm not sure I completely understood what you have asked of me, could you please check my code, as it error's as a compile error in the bold highlighted text

Thanks

Private Sub Application_Reminder(ByVal Item As Object)
Set olRemind = Outlook.Reminders
If Item.Subject = "Birthday Text" Then
Dim olkContacts As Outlook.Items, _
olkContact As Object, _
olkMsg As Outlook.MailItem
Set olkContacts = Session.GetDefaultFolder(olFolderContacts).Items
For Each olkContact In olkContacts
If olkContact.Class = olContact Then
If (Month(olkContact.Birthday) = Month(Date)) And (Day(olkContact.Birthday) = Day(Date)) Then
Set olkMsg = Application.CreateItem(olMailItem)
With olkMsg
.Recipients.Add olkContact.Email1Address
'Change the subject as needed'
.Subject = "Happy Birthday " & olkContact.FirstName
'Change the message as needed'
.HTMLBody = "Hi " & olkContact.FirstName & " Happy Birthday"
'Change Display to Send if you want the messages sent automatically'
.Display
End With
End If
End If
Next
Set olkMsg = Nothing
Set olkContact = Nothing
Set olkContacts = Nothing
End If
End Sub
Private Sub olRemind_BeforeReminderShow(Cancel As Boolean)
Private WithEvents olRemind As Outlook.Reminders
For Each objRem In olRemind
If objRem.Caption = "Birthday Text" Then
If objRem.IsVisible Then
objRem.Dismiss
Cancel = True
End If
Exit For
End If
Next objRem
End Sub

End Sub on this to be deleted.

' declare this object withEvents displaying all the events
Private WithEvents olRemind As Outlook.Reminders
End Sub

As well in case this is located as shown here move Private WithEvents olRemind As Outlook.Reminders to the top of the module after Option Explicit

[skatonni]

' This goes at the top of the ThisOutlookSession module
Private WithEvents olRemind As outlook.Reminders

Private Sub Application_Reminder(ByVal Item As Object)

[crows]

Thank you so much, shifting it to the top of the module fixed it.
Thanks again, for others who may be interested here is the final script.

Private WithEvents olRemind As Outlook.Reminders
Private Sub Application_Reminder(ByVal Item As Object)
Set olRemind = Outlook.Reminders
If Item.Subject = "Birthday Text" Then
Dim olkContacts As Outlook.Items, _
olkContact As Object, _
olkMsg As Outlook.MailItem
Set olkContacts = Session.GetDefaultFolder(olFolderContacts).Items
For Each olkContact In olkContacts
If olkContact.Class = olContact Then
If (Month(olkContact.Birthday) = Month(Date)) And (Day(olkContact.Birthday) = Day(Date)) Then
Set olkMsg = Application.CreateItem(olMailItem)
With olkMsg
.Recipients.Add olkContact.Email1Address
'Change the subject as needed'
.Subject = "Happy Birthday " & olkContact.FirstName
'Change the message as needed'
.HTMLBody = "Hi " & olkContact.FirstName & " Happy Birthday"
'Change Display to Send if you want the messages sent automatically'
.Display
End With
End If
End If
Next
Set olkMsg = Nothing
Set olkContact = Nothing
Set olkContacts = Nothing
End If
End Sub
Private Sub olRemind_BeforeReminderShow(Cancel As Boolean)
For Each objRem In olRemind
If objRem.Caption = "Birthday Text" Then
If objRem.IsVisible Then
objRem.Dismiss
Cancel = True
End If
Exit For
End If
Next objRem
End Sub

Hi again,

I'm not sure I completely understood what you have asked of me, could you please check my code, as it error's as a compile error in the bold highlighted text

Thanks

Private Sub Application_Reminder(ByVal Item As Object)
Set olRemind = Outlook.Reminders
If Item.Subject = "Birthday Text" Then
Dim olkContacts As Outlook.Items, _
olkContact As Object, _
olkMsg As Outlook.MailItem
Set olkContacts = Session.GetDefaultFolder(olFolderContacts).Items
For Each olkContact In olkContacts
If olkContact.Class = olContact Then
If (Month(olkContact.Birthday) = Month(Date)) And (Day(olkContact.Birthday) = Day(Date)) Then
Set olkMsg = Application.CreateItem(olMailItem)
With olkMsg
.Recipients.Add olkContact.Email1Address
'Change the subject as needed'
.Subject = "Happy Birthday " & olkContact.FirstName
'Change the message as needed'
.HTMLBody = "Hi " & olkContact.FirstName & " Happy Birthday"
'Change Display to Send if you want the messages sent automatically'
.Display
End With
End If
End If
Next
Set olkMsg = Nothing
Set olkContact = Nothing
Set olkContacts = Nothing
End If
End Sub
Private Sub olRemind_BeforeReminderShow(Cancel As Boolean)
Private WithEvents olRemind As Outlook.Reminders
For Each objRem In olRemind
If objRem.Caption = "Birthday Text" Then
If objRem.IsVisible Then
objRem.Dismiss
Cancel = True
End If
Exit For
End If
Next objRem
End Sub

[crows]

Hi again, I have a problem that because the script actually dismiss's the task it never starts again, the nature of tasks re-occuring is that they need to be marked as complete so that it triggers another daily task. Is there anything I can do to modify this existing script that it marks the task as completed rather than dismiss it....here is the script again:

Private WithEvents olRemind As Outlook.Reminders
Private Sub Application_Reminder(ByVal Item As Object)
Set olRemind = Outlook.Reminders
If Item.Subject = "Birthday Text" Then
Dim olkContacts As Outlook.Items, _
olkContact As Object, _
olkMsg As Outlook.MailItem
Set olkContacts = Session.GetDefaultFolder(olFolderContacts).Items
For Each olkContact In olkContacts
If olkContact.Class = olContact Then
If (Month(olkContact.Birthday) = Month(Date)) And (Day(olkContact.Birthday) = Day(Date)) Then
Set olkMsg = Application.CreateItem(olMailItem)
With olkMsg
.Recipients.Add olkContact.Email1Address
'Change the subject as needed'
.Subject = "Happy Birthday " & olkContact.FirstName
'Change the message as needed'
.HTMLBody = "Hi " & olkContact.FirstName & " Happy Birthday"
'Change Display to Send if you want the messages sent automatically'
.Display
End With
End If
End If
Next
Set olkMsg = Nothing
Set olkContact = Nothing
Set olkContacts = Nothing
End If
End Sub
Private Sub olRemind_BeforeReminderShow(Cancel As Boolean)
For Each objRem In olRemind
If objRem.Caption = "Birthday Text" Then
If objRem.IsVisible Then
objRem.Dismiss
Cancel = True
End If
Exit For
End If
Next objRem
End Sub

[gmayor]

If you really must do this then see https://www.datanumen.com/blogs/auto...y-outlook-vba/

However your contact knows it is his/her birthday and there is nothing that expresses disinterest more than sending a computer generated e-mail to confirm it. If the person is important to you, it would be much better to telephone and wish him/her a happy birthday or perhaps send a hand written birthday card. If the person is not that important then it is better not to send the message at all.

[skatonni]

Not dismissing the task, dismissing the reminder. Regardless does not fit your way.

This puts in a completed date. I assume you have set the recurrence to generate a new task when there is a completed date.

Option Explicit

Private WithEvents olRemind As Reminders

Private Sub Application_Reminder(ByVal Item As Object)

    Dim olkContacts As Items
    Dim olkContact As Object
    Dim olkMsg As MailItem
    
    Dim MyTaskFolder As Folder
    
    Dim myTaskItems As Items
    Dim myBirthdayTasks As Items
    
    Dim myBirthdayTask As Object

    Set olRemind = Reminders
    
    If Item.subject = "Birthday Text" Then
        
        Set olkContacts = Session.GetDefaultFolder(olFolderContacts).Items
        
        For Each olkContact In olkContacts
            If olkContact.Class = olContact Then
                If (Month(olkContact.Birthday) = Month(Date)) And (Day(olkContact.Birthday) = Day(Date)) Then
                    Set olkMsg = Application.CreateItem(olMailItem)
                    With olkMsg
                        .Recipients.Add olkContact.Email1Address
                        'Change the subject as needed'
                        .subject = "Happy Birthday " & olkContact.FirstName
                        'Change the message as needed'
                        .HTMLBody = "Hi " & olkContact.FirstName & " Happy Birthday"
                        'Change Display to Send if you want the messages sent automatically'
                        .Display
                    End With
                End If
            End If
        Next
        
        Set MyTaskFolder = Session.GetDefaultFolder(olFolderTasks)
        Set myTaskItems = MyTaskFolder.Items
        
        Set myBirthdayTasks = myTaskItems.Restrict("[Subject] = ""Birthday Text""")

        For Each myBirthdayTask In myBirthdayTasks
            
            If myBirthdayTask.DueDate = Date Then
                myBirthdayTask.DateCompleted = Date
                myBirthdayTask.Save
                Exit For
            End If
            
        Next
    
    End If
    
    Set olkMsg = Nothing
    Set olkContact = Nothing
    Set olkContacts = Nothing

End Sub


Private Sub olRemind_BeforeReminderShow(Cancel As Boolean)

     Dim objRem As Reminder
     
     For Each objRem In olRemind
        If objRem.Caption = "Birthday Text" Then
            If objRem.IsVisible Then
                objRem.Dismiss
                Cancel = True
            End If
            Exit For
        End If
    Next objRem
    
End Sub

[crows]

Hi thanks for the updated script, it seems to work, however after it executes it has a command debug box that says there is an error and it highlights this line in the script:

If objRem.Caption = "Birthday Text" Then

Not sure why?

Thanks

Not dismissing the task, dismissing the reminder. Regardless does not fit your way.

This puts in a completed date. I assume you have set the recurrence to generate a new task when there is a completed date.

Option Explicit

Private WithEvents olRemind As Reminders

Private Sub Application_Reminder(ByVal Item As Object)

    Dim olkContacts As Items
    Dim olkContact As Object
    Dim olkMsg As MailItem
    
    Dim MyTaskFolder As Folder
    
    Dim myTaskItems As Items
    Dim myBirthdayTasks As Items
    
    Dim myBirthdayTask As Object

    Set olRemind = Reminders
    
    If Item.subject = "Birthday Text" Then
        
        Set olkContacts = Session.GetDefaultFolder(olFolderContacts).Items
        
        For Each olkContact In olkContacts
            If olkContact.Class = olContact Then
                If (Month(olkContact.Birthday) = Month(Date)) And (Day(olkContact.Birthday) = Day(Date)) Then
                    Set olkMsg = Application.CreateItem(olMailItem)
                    With olkMsg
                        .Recipients.Add olkContact.Email1Address
                        'Change the subject as needed'
                        .subject = "Happy Birthday " & olkContact.FirstName
                        'Change the message as needed'
                        .HTMLBody = "Hi " & olkContact.FirstName & " Happy Birthday"
                        'Change Display to Send if you want the messages sent automatically'
                        .Display
                    End With
                End If
            End If
        Next
        
        Set MyTaskFolder = Session.GetDefaultFolder(olFolderTasks)
        Set myTaskItems = MyTaskFolder.Items
        
        Set myBirthdayTasks = myTaskItems.Restrict("[Subject] = ""Birthday Text""")

        For Each myBirthdayTask In myBirthdayTasks
            
            If myBirthdayTask.DueDate = Date Then
                myBirthdayTask.DateCompleted = Date
                myBirthdayTask.Save
                Exit For
            End If
            
        Next
    
    End If
    
    Set olkMsg = Nothing
    Set olkContact = Nothing
    Set olkContacts = Nothing

End Sub


Private Sub olRemind_BeforeReminderShow(Cancel As Boolean)

     Dim objRem As Reminder
     
     For Each objRem In olRemind
        If objRem.Caption = "Birthday Text" Then
            If objRem.IsVisible Then
                objRem.Dismiss
                Cancel = True
            End If
            Exit For
        End If
    Next objRem
    
End Sub

[skatonni]

Cannot even guess why without the description. You may have to drop the automatic dismiss part of the code.

[crows]

Sorry, the first image is the error the second image is when I click on debug.

error.JPGerror1.JPG

Cannot even guess why without the description. You may have to drop the automatic dismiss part of the code.