Thank you Dmitry.

The code grows and grows:

Sub CreateAppointments(ByVal lngFrom As Long, ByVal lngTo As Long)

Dim objAppointments As Outlook.Items
Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link
Dim lngIndex As Long

Set objContacts =
Outlook.Session.GetDefaultFolder(olFolderContacts) .Items
Set objAppointments =
Outlook.Session.GetDefaultFolder(olFolderCalendar) .Items

For lngIndex = lngFrom To lngTo
Set objContact = objContacts(lngIndex)
Set objApp = objAppointments.Add
Set colLinks = objApp.Links
With objApp
.ReminderSet = False
.Subject = objContact.Subject
Set objLink = colLinks.Add(objContact)
.Save
End With
Set objLink = Nothing
Set colLinks = Nothing
Set objApp = Nothing
Set objContact = Nothing
Next

End Sub

But the error still remains. Any other ideas?

Peter

On 5 Nov., 21:57, "Dmitry Streblechenko" wrote:
Links.Add returns a Link object, which your code does not reference and
hence cannot release:

set Link = .Links.Add ...
set Link = Nothing

Dmitry Streblechenko (MVP)http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool

"Peter Marchert" wrote in message

ps.com...



On 5 Nov., 18:12, "Dmitry Streblechenko" wrote:
You are still using multiple dot notation (.Links.Add)
What happens if you comment out that line?

If the line is commented out the code works fine. I tried this one:

Sub CreateAppointments(ByVal lngFrom As Long, ByVal lngTo As Long)

Dim objAppointments As Outlook.Items
Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim lngIndex As Long

Set objContacts =
Outlook.Session.GetDefaultFolder(olFolderContacts) .Items
Set objAppointments =
Outlook.Session.GetDefaultFolder(olFolderCalendar) .Items

For lngIndex = lngFrom To lngTo
Set objContact = objContacts(lngIndex)
Set objApp = objAppointments.Add
Set colLinks = objApp.Links
With objApp
.ReminderSet = False
.Subject = objContact.Subject
Call colLinks.Add(objContact)
.Save
End With
Set colLinks = Nothing
Set objApp = Nothing
Set objContact = Nothing
Next

End Sub

But the error comes back.

Peter- Zitierten Text ausblenden -

- Zitierten Text anzeigen -