Age of people in Outlook calendar 1

[wmbb]

I'm importing Outlook calendar items (birthdays) using the code below...

Sub AddBirthday(bName As String, bDate As Date)
    Dim NewBday As Outlook.AppointmentItem
    Dim NewPatt As Outlook.RecurrencePattern
    
    Set olns = ThisOutlookSession.Application.GetNamespace("MAPI")
    Set ContactFolder = olns.GetDefaultFolder(olFolderContacts)
    Set CalendarFolder = olns.GetDefaultFolder(olFolderCalendar)
    Set MyContacts = ContactFolder.Items
    Set MyBirthdays = CalendarFolder.Items
    
    Set NewBday = Outlook.CreateItem(olAppointmentItem)
        NewBday.AllDayEvent = True
    Set NewPatt = NewBday.GetRecurrencePattern
        NewPatt.RecurrenceType = olRecursYearly
        NewPatt.PatternStartDate = bDate
        NewPatt.NoEndDate = True
        NewPatt.DayOfMonth = Day(bDate)
        NewPatt.MonthOfYear = Month(bDate)
        NewBday.MeetingStatus = olNonMeeting
        NewBday.Subject = "Birthday " & bName & " " & Year(bDate)
        NewBday.Start = bDate
        NewBday.BusyStatus = olFree
        NewBday.Save
End Sub

Sub test()
    AddBirthday "Testname", "2000-10-6"
End Sub

Now the appointment subject is like "Birthday Testname 2000"
Is it possible to show the age in each occurrence instead of the year of birth ?

 

[strongm]

Yes, it is. But it needs a tiny additional function:

[green]' Calculates the age in years on a given date, CalcDate, of a person born on BirthDate.
' If CalcDate not provided, function defaults to today's date
' Note: takes time into account[/green][blue]
Public Function Age(BirthDate As Date, Optional CalcDate As Date = 0) As Long
    If CalcDate = 0 Then CalcDate = Now()
    Age = DateDiff("yyyy", BirthDate, CalcDate)
    If DateAdd("yyyy", -Age, CalcDate) < BirthDate Then Age = Age - 1
End Function[/blue]

Then change your line of code from:

[tt]NewBday.Subject = "Birthday " & bName & " " & Year(bDate)[/tt]

to

[tt]NewBday.Subject = "Birthday " & bName & " " & Age(bDate)[/tt]

 

[wmbb]

Hello Strongm,

Thanks for your response but this doesn't work like I want.
For the instance of 2015 it is OK and the subject is "Birthday Testname 15" but for the instance of next year (2016) the subject is also "Birthday Testname 15".
Maybe this is a way to stay young but the subject of next year should be "Birthday Testname 16" !
I've tried several things but I don't think it's possible with a recurrence appointment.....

Maybe it is possible to change all instances of the series after the import but I don't know how to do it.
Manually it is possible to change the subject of the individual appointments but I want to do it within the import procedure.

 

[strongm]

Works fine here. How did you call the function, and with what parameters?

 

[wmbb]

Hi, I changed the code from:

NewBday.Subject = "Birthday " & bName & " " & Year(bDate)
to
NewBday.Subject = "Birthday " & bName & " " & Age(bDate)

and I've run the sub test() as shown

 

[strongm]

Right, you might want to read the comments for the function ...

However, are you also saying that you want a different subject for each occurrence of a recurring appointment? Not quite sure that is possible.

 

[wmbb]

I did read the comments but I don't understand the comment....

I don't want to show the age compared to one specific date but I want to display the age on the date of the occurrence.

in 2015 the age 15 should be displayed
in 2016 the age of 16 should be displayed
etc.

Manually it is possible to change the subject of the individual appointments of a recurring appointment but I want to do it within the import procedure.

 

[Andrzejek]

strongm's function [tt]Age[/tt] accepts 2 parameters: required [tt]BirthDate As Date[/tt] which you provided, and [tt]Optional CalcDate As Date [/tt] which is, well, optional. If you do not provide CalcDate, then its value is 0 (BTW, 0 is Dec 30, 1899) but it is converted to today's date and time.

Try something like this:
Today:
NewBday.Subject = "Birthday " & bName & " " & Age(bDate, DateAdd("yyyy", [blue]0[/blue], Date))
Next year:
NewBday.Subject = "Birthday " & bName & " " & Age(bDate, DateAdd("yyyy", [blue]1[/blue], Date))
Next year:
NewBday.Subject = "Birthday " & bName & " " & Age(bDate, DateAdd("yyyy", [blue]2[/blue], Date))

Have fun.

---- Andy

A bus station is where a bus stops. A train station is where a train stops. On my desk, I have a work station.

 

[wmbb]

I have understood the function but it didn't meet my requirements.
Your suggestion is not possible for a recurring appointment I think.

After a day's research I think I have to import the list as a recurring appointment and after that walk through the occurences one by one and change the subject just for that occurence. I just don't know how to do that right now in VBA.

 

[softhemc]

If you assume someone was born in 10th June 2000, how old will they be in March 2016?

As they won't yet have had their birthday in 2016 they will still be 15 (not 16 until 10th June 2016) - strongm's code handles this eventuality.

 

[wmbb]

I just want the recurring appointment on the birthday so I don't worry about the age in march 2016.
The idea is to create a reminder in the calendar using an import list and it would be nice if you could see how old someone is going to be.

I found some quote on the internet giving the direction I have to go I think.....
"Changes to instances of a recurring appointment will cause that modified appointment to be placed in the Exceptions collection of the RecurrencePattern. You can iterate the collection ....."

 

[strongm]

>I don't want to show the age compared to one specific date but I want to display the age on the date of the occurrence.

Which is exactly what the function can do, and which the comments describe.

[tt]Age(bDate)[/tt] gives you the age today
[tt]Age(bDate, #1 Aug 2016#)[/tt] gives you the age on 1st Aug 2016

>Manually it is possible to change the subject of the individual appointments of a recurring appointment
Indeed

>I want to do it within the import procedure.
Yes, and this is the somewhat tricky bit. You can't do it by setting the subject line on the recurring meeting. You need to visit each instance of the recurrence and change that instance. And that means that you need to think about your requirements more carefully. For example, you currently seem to be setting no end date for the recurrence, so exactly how many years in the future do you want to update the subject line for?

 

[strongm]

>but it didn't meet my requirements

It is pretty much the basis for the very minor modification you have to make to your code. Here's an example:

[blue]Option Explicit

Public Sub test()
    AddBirthday "test", #10/6/2001#
End Sub

Public Sub AddBirthday(bName As String, bdate As Date[COLOR=#204A87], Optional yearsinfuture As Long = 5[/color])
    Dim NewBday As Outlook.AppointmentItem
    Dim NewPatt As Outlook.RecurrencePattern
    [b][COLOR=#204A87]Dim olns As Outlook.NameSpace
    Dim ContactFolder As Outlook.Folder
    Dim CalendarFolder As Outlook.Folder
    Dim MyContacts As Outlook.Items
    Dim myBirthdays As Outlook.Items
    
    Dim StartDate As Date
    Dim EndDate As Date
    Dim Appt As Outlook.AppointmentItem[/color][/b]
    
    Set olns = ThisOutlookSession.Application.GetNamespace("MAPI")
    Set ContactFolder = olns.GetDefaultFolder(olFolderContacts)
    Set CalendarFolder = olns.GetDefaultFolder(olFolderCalendar)
    Set MyContacts = ContactFolder.Items
    Set myBirthdays = CalendarFolder.Items
    
    Set NewBday = Outlook.CreateItem(olAppointmentItem)
    NewBday.AllDayEvent = True
    Set NewPatt = NewBday.GetRecurrencePattern
    NewPatt.RecurrenceType = olRecursYearly
    NewPatt.PatternStartDate = bdate
    NewPatt.NoEndDate = True
    NewPatt.DayOfMonth = Day(bdate)
    NewPatt.MonthOfYear = Month(bdate)
    NewBday.MeetingStatus = olNonMeeting
    NewBday.Subject = [COLOR=#204A87][b]"Birthday Placeholder"[/b][/color]
    NewBday.Start = bdate
    NewBday.BusyStatus = olFree
    NewBday.Save
    
    [green][b]' Now update reoccurrences (this is basically the modification)[/green]
    [COLOR=#204A87]StartDate = Format(bdate, "dd mmm yyyy")
    EndDate = DateAdd("yyyy", yearsinfuture, Date) [green]' for up to yearsinfuture years in future[/green]
    Do While StartDate < EndDate
        Set Appt = NewBday.GetRecurrencePattern.GetOccurrence(StartDate)
        Appt.Subject = "Birthday " & bName & " " & Age(bdate, Appt.Start)
        Appt.Save
        StartDate = DateAdd("yyyy", 1, StartDate)
    Loop[/color][/b]

End Sub

[green]' Calculates the age in years on a given date, CalcDate, of a person born on BirthDate.
' If CalcDate not provided, function defaults to today's date
' Note: takes time into account[/green]
Public Function Age(BirthDate As Date, Optional CalcDate As Date = 0) As Long
    If CalcDate = 0 Then CalcDate = Now()
    Age = DateDiff("yyyy", BirthDate, CalcDate)
    If DateAdd("yyyy", -Age, CalcDate) < BirthDate Then Age = Age - 1
End Function[/blue]

 

[wmbb]

Hello,
I hadn't thought about the missing end date.
You're right that is an issue....
What seemed to be an easy job turns out to grow above my knowledge ;-(

But many thanks for your help and I'm learning a lot from your respond and the research getting this job done.

I'll try to understand your last code tomorrow and see if it works.

 

[wmbb]

Hello Strongm,

I understand the code and it works perfect !!!
A star for you !
Thanks again for your help.