here is a function that should do the job:
Folder "OL2002" -> Item 36 on http://www.DocOutlook.de/
--
Viele Grüße
Michael Bauer
"Jaded in Cali" <Jaded in Ca...@discussions.microsoft.com> wrote in
message news:6595D29E-9AEC-465A...@microsoft.com...
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
--
Viele Grüße
Michael Bauer
"Jaded in Cali" <Jaded in Ca...@discussions.microsoft.com> wrote in
message news:8CF4C806-AA6F-4780...@microsoft.com...
http://www.outlook-stuff.com/component/option,com_docman/task,doc_details/gid,26/Itemid,2/
Peter
--
Infos, workshops & software for
Outlook®: www.outlook-stuff.com
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
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
> > ck- Zitierten Text ausblenden -
>
> - Zitierten Text anzeigen -
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