VBA routine to calendar birthdays from imported contacts.

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I am a teacher and use Outlook to manage student information, parent contact
notes, etc. I imported the student information for over 100 students from an
Excel spreadsheet created by the schools data management system. The
birthdays did not make it to my Calendar. Instead of opening and changeing
each individual birthday and resaving the card, is there a way use VBA to
calendar
them all at once?
 
Thanks of the link. The site is in German or Danish or something, so I had
to poke around, but I found the VBA scriptand with the following
modifications, it worked fine:

1. My VBA editor opens with Option Explicit, so I had to Dim i and
mybirthday.
2. The date is in European format: xx.xx.xxxx, which Outlook did not
recognize. I changed it to xx/xx/xxxx, which worked fine.

Thanks again.

--j
 
Could somebody post the code here that works for English. I have hundred of
contacts and need to recreate the birthdays. I couldn't make sense out of
the German webpage quoted here, but need to do the same this: I'm assuming
it uses VBA to make the birthday dirty, so it will be recreated by outlook on
o my calender.
thanks,
charlie
 
I don't really like the idea of installing foriegn language programs, I
don't know what problems I might be creating...
If a person had a little vba code that looped through all thecontacts, and
changed the birthday to a different day, then changed it back to what it was
originally, and saved it, would this cause Outlook 2003 to reload them into
the calendar?
Would this code be very complex to come up with?
thanks,
ck
 
Here is some code to create birthday appointments:

Sub CreateBirthdays()

Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim objAppointment As Outlook.AppointmentItem
Dim objCalendar As Outlook.MAPIFolder
Dim objRecPattern As Outlook.RecurrencePattern
Dim colLinks As Outlook.Links

If
InStr(UCase(Outlook.ActiveExplorer.CurrentFolder.DefaultMessageClass),
"IPM.CONTACT") = 0 Then
MsgBox "Please select a contact folder.", vbCritical +
vbOKOnly
Exit Sub
End If

Set objCalendar =
Outlook.Session.GetDefaultFolder(olFolderCalendar)
Set objContacts = Outlook.ActiveExplorer.CurrentFolder.Items

For Each objContact In objContacts

If Year(objContact.Birthday) <> 4501 Then
Set objAppointment = objCalendar.Items.Add
Set colLinks = objAppointment.Links
With objAppointment
.Subject = Trim(objContact.FirstName & " " & _
objContact.LastName) & "'s Birthday"
.Start = objContact.Birthday
.AllDayEvent = True
Call colLinks.Add(objContact)
Set objRecPattern = .GetRecurrencePattern
objRecPattern.RecurrenceType = olRecursYearly
objRecPattern.PatternStartDate = objContact.Birthday
.Save
End With
End If

Set colLinks = Nothing
Set objContact = Nothing
Set objAppointment = Nothing
Set objRecPattern = Nothing

Next

End Sub

Can occour an error if you use an exchange server without cache mode.
If so simply press F5 to continue. If you break the code you have to
delete all created items in the calendar before start it again,
because the code does not check if the item exists.

I think the tool is the better way but now you have the choise.

Peter
 
May be you have problems to get the code running because when posting
the lines will be breaked. I tried to shorted them and insert a check
that skip distlist items:

Sub CreateBirthdays()

Dim objContacts As Outlook.Items
Dim objItem As Object
Dim objAppointment As Outlook.AppointmentItem
Dim objCalendar As Outlook.MAPIFolder
Dim objFolder As Outlook.MAPIFolder
Dim objRec As Outlook.RecurrencePattern
Dim colLinks As Outlook.Links

Set objFolder = Outlook.ActiveExplorer.CurrentFolder
If InStr(UCase(objFolder.DefaultMessageClass), _
"IPM.CONTACT") = 0 Then
MsgBox "Please select a contact folder.", 16
Exit Sub
End If

Set objCalendar = _
Outlook.Session.GetDefaultFolder(olFolderCalendar)
Set objContacts = _
Outlook.ActiveExplorer.CurrentFolder.Items

For Each objItem In objContacts

If objItem.Class <> olContact Then GoTo Skippy

If Year(objItem.Birthday) <> 4501 Then
Set objAppointment = objCalendar.Items.Add
Set colLinks = objAppointment.Links
With objAppointment
.Subject = Trim(objItem.FirstName & " " & _
objItem.LastName) & "'s Birthday"
.Start = objItem.Birthday
.AllDayEvent = True
Call colLinks.Add(objItem)
Set objRec = .GetRecurrencePattern
objRec.RecurrenceType = olRecursYearly
objRec.PatternStartDate = objItem.Birthday
.Save
End With
End If
Skippy:
Set colLinks = Nothing
Set objItem = Nothing
Set objAppointment = Nothing
Set objRec = Nothing

Next

Set objFolder = Nothing
Set objCalendar = Nothing

End Sub

Peter
 
Peter, I have 663 birthdays to add to my bosses' calendar. The person in
charge of the list adds the employees' birthdays in the birthday field in
Outlook Contacts. I delete my contacts in my personal folder and copy her
contacts lists each month to my folder because the employees are ever
changing.

Where do I go to add this code so the birthdays automatically display in my
contacts? And, are they recurring each year on that date? If not, is there
code to make them recurring? Since I don't have access to my bosses' contact
list, I guess the only way to get them on my bosses' calendar, is to drag
them over, unless you have a faster way of doing this. Also, if there are
old entries, can it compare to see if they are currently on the new list, and
if not, delete that reocurring entry?

Anything you do to help me automate this task would be greatly appreciated.

Susan
 
Back
Top