Outlook MACROs: Contact Birthdays and Private Appointments (VBA Code)

[Guest madu]

You may find this useful if you:

- use Microsoft Outlook and synchronize your device with PC;

- birthdays in calendar have shifted in date, but birth date is OK in contact(s);

- use Microsoft Exchange, share your calendar and want birthdays to be set to Private;

- want to have birthday reminders other than at 23:45;

WARNING: Back up Outlook data file before using this solution. Use at your own risk.

Tested on MS Outlook 2007.

My solution is based on the solutions that can be found here:

http://www.outlookcode.com/d/code/remindbday.htm

http://the-trusted-adviser.spaces.live.com...C!513.entry

Thanks A LOT to the authors!

SOLUTION 1

You want Outlook to automatically set appointment to Private and reminder time to 22:00 when a new birthday event is added to calendar by Outlook.

DEFAULT BEHAVIOR:

- create contact or select existing contact

- go to details and set birth date

- save contact

* Appointment automatically created BUT not set to private and reminder time used as set in settings (Tools>Options>Default reminder) 15 minutes.

TARGET BEHAVIOUR:

- create contact or select existing contact

- go to details and set birth date

- save contact

* Appointment automatically created and set to PRIVATE with reminder 2 hours before birthday date (22:00).

Use code below as described here: http://www.outlookcode.com/d/code/remindbday.htm (my code is modified):

In Outlook, press Alt+F11 to open VBA window, then double-click "ThisOutlookSession" in the left pane and paste code. Then close VBA window. Done.

Dim WithEvents mcolCalItems As Items


Private Sub Application_MAPILogonComplete()

    Dim objNS As NameSpace

    Set objNS = Application.GetNamespace("MAPI")

    Set mcolCalItems = objNS.GetDefaultFolder(olFolderCalendar).Items

    Set objNS = Nothing

End Sub


Private Sub mcolCalItems_ItemAdd(ByVal Item As Object)


    If Item.Class = olAppointment And _

       InStr(Item.Subject, "Birthday") > 0 Then

        With Item

            .ReminderSet = True

            .ReminderMinutesBeforeStart = 120         'REMINDER TIME BEFORE DATE in MINUTES 120min = 2 hours

            .Sensitivity = olPrivate                            'THIS MAKES APPOINTMENT PRIVATE

            .Save

        End With

    End If

End Sub[/codebox]

[b]SOLUTION 2[/b]

You want to batch re/create all (or selected) birthday items in Calendar based on info in Contacts.

Useful if you import contacts or have problems with birthdays (appear one day before) in calendar due to time zone change or DST.

Follow the link below for step by step solution, but use MY CODE:

http://the-trusted-adviser.spaces.live.com...p;wa=wsignin1.0

BEFORE RUNNING THE CODE: Create a subfolder in Outlook/Calendar folder and MOVE all recurring appointments (birthdays) to this new folder.

TIP: Use Tools > Organize > Using Views > Recurring appointments for easy filtering and multiple selection - Select desired contacts, press Alt+F8 run macro NewBirthdayReminder.

[codebox]Sub NewBirthdayReminder()

Dim objApp As Outlook.Application
Dim objNS As NameSpace
Dim objSelection As Outlook.Selection
Dim objItem As ContactItem

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")

Set objSelection = objApp.ActiveExplorer.Selection

MsgBox ("Converting " & objSelection.Count)

For Each objItem In objSelection

objItem.Birthday = objItem.Birthday

objItem.Save

Next

End Sub

SOLUTION 3

You want to batch process Appointments in Calendar to set REMINDER TIME or PRIVATE (sensitivity).

Useful if you use Microsoft Exchange and SHARE your calendar. You want your contacts' birthdays to be invisible to others.

Follow the link below for step by step solution, but use MY CODE:

http://the-trusted-adviser.spaces.live.com...p;wa=wsignin1.0

TIP: Use Tools > Organize > Using Views > Recurring appointments for easy filtering and multiple selection - Select desired contacts, press Alt+F8 run macro MarkAppointmentPrivate.

Sub MarkAppointmentPrivate()


    Dim objApp As Outlook.Application

    Dim objNS As NameSpace

    Dim objSelection As Outlook.Selection

    Dim objItem As AppointmentItem


    Set objApp = CreateObject("Outlook.Application")

    Set objNS = objApp.GetNamespace("MAPI")


    Set objSelection = objApp.ActiveExplorer.Selection


    'Set mcolCalItems = objNS.GetDefaultFolder(olFolderCalendar).Items 'test


    MsgBox ("Converting " & objSelection.Count)


    For Each objItem In objSelection


        With objItem

            .ReminderSet = True

            .Sensitivity = olPrivate                            'THIS MAKES APPOINTMENT PRIVATE

            .Save

        End With


        objItem.Save


    Next


End Sub[/codebox]

[b]SOLUTION 4[/b]

You want to batch process Appointments in Calendar to set REMINDER TIME.

Useful if you want NEW reminder time to be set to all birthdays at once. If you do not like to wake up at 23:45 to snooze the reminder.

Follow the link below for step by step solution, but use MY CODE:

http://the-trusted-adviser.spaces.live.com...p;wa=wsignin1.0

TIP: Use Tools > Organize > Using Views > Recurring appointments for easy filtering and multiple selection - Select desired contacts, press Alt+F8 run macro MarkAppointmentTime.

[codebox]Sub MakeAppointmentTime()

Dim objApp As Outlook.Application
Dim objNS As NameSpace
Dim objSelection As Outlook.Selection
Dim objItem As AppointmentItem

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")

Set objSelection = objApp.ActiveExplorer.Selection

'Set mcolCalItems = objNS.GetDefaultFolder(olFolderCalendar).Items 'test

MsgBox ("Converting " & objSelection.Count)

For Each objItem In objSelection

With objItem
.ReminderSet = True
.ReminderMinutesBeforeStart = 120 'REMINDER TIME BEFORE DATE in MINUTES 120min = 2 hours
.Save
End With

objItem.Save

Next

End Sub

Thanks again to the authors of the original code.

GOOD LUCK

PS: Sorry for limited walkthrough and guiding, I have very little time but really wanted to post this solution.

Edited August 11, 2008 by madu

[Guest chucky.egg]

Yeah, I like this stuff.

I keep meaning to "fix" the reminder time for birthdays to be something sensible - rather than midnight! I want to know a few days in advance, and at a reasonable time of day (just before lunch would be good so I can get a card/present)

Now you've reminded me I might just get around to doing it!

[Guest madu]

In case you work by hours, replace the following line with new:

.ReminderMinutesBeforeStart = 120

replace to:

.ReminderMinutesBeforeStart = 60*XX

where XX is number of hours.

so if you want reminder at 12:00 two days before it should be

.ReminderMinutesBeforeStart = 60*36

[Guest Praha1]

In case you work by hours, replace the following line with new:

.ReminderMinutesBeforeStart = 120

replace to:

.ReminderMinutesBeforeStart = 60*XX

where XX is number of hours.

so if you want reminder at 12:00 two days before it should be

.ReminderMinutesBeforeStart = 60*36

Would anyone have a script to change create birthdays from contacts but limit the recurrence to a specific number of time / number of annual events instead of having no end date?

Or just a script that can change recurring events with no end to to a specific number of time / number of events