A Microsoft Outlook email forum. Outlook Banter

If this is your first visit, be sure to check out the FAQ by clicking the link above. You may have to register before you can post: click the register link above to proceed. To start viewing messages, select the forum that you want to visit from the selection below.

Go Back   Home » Outlook Banter forum » Microsoft Outlook Email Newsgroups » Outlook and VBA
Reload this Page Error when creating 247 appointments in exchange mailbox
Site Map Home Register Authors List Search Today's Posts Mark Forums Read Web Partners

Tags: , , , , ,

Error when creating 247 appointments in exchange mailbox


Outlook On-site Training


« Merging html files | MapiTable in OL 2000 slow »

 
Page 3 of 4 12 3 4
 
Thread Tools Display Modes
  #21  
Old November 7th 07, 07:11 AM posted to microsoft.public.outlook.program_vba
Dmitry Streblechenko
external usenet poster
  
Posts: 1,592
Default Error when creating 247 appointments in exchange mailbox
I can only suggest to use Redemption, which does not leave hanging
references...

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

"Peter Marchert" wrote in message
ups.com...
Thanks for your idea, Ken.

I`m sorry, but there is no change.

Peter

On 6 Nov., 21:47, "Ken Slovak - [MVP - Outlook]"
wrote:
Peter, see if this is any better:

Public objContacts As Outlook.Items
Public objContact As Outlook.ContactItem

Public objAppointments As Outlook.Items

Public objApp As Outlook.AppointmentItem
Public colLinks As Outlook.Links
Public objLink As Outlook.Link

Sub Test()
Dim oNS As Outlook.NameSpace

Set oNS = Outlook.GetNameSpace("MAPI")

Set objContacts = _
oNS.GetDefaultFolder(olFolderContacts).Items

Set objAppointments = _
oNS.GetDefaultFolder(olFolderCalendar).Items

Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)

Set objContacts = Nothing
Set objContact = Nothing

Set objAppointments = Nothing

Set objApp = Nothing
Set colLinks = Nothing
Set objLink = Nothing
End Sub

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts.Item(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next
End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)
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
End Sub

--
Ken Slovak
[MVP - Outlook]http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment
Optionshttp://www.slovaktech.com/products.htm

"Peter Marchert" wrote in message

oups.com...



Thank you Dmitry, but the error is still the

Sub Test()
Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)
End Sub

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

Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim lngIndex As Long

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next

End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link

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

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

End Sub

Peter- Zitierten Text ausblenden -

- Zitierten Text anzeigen -
Ads
  #22  
Old November 7th 07, 07:21 AM posted to microsoft.public.outlook.program_vba
Peter Marchert
external usenet poster
  
Posts: 116
Default Error when creating 247 appointments in exchange mailbox
How to do that? This code occurs the same error:

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link
Dim objSafeApp As Object

Set objAppointments =
Outlook.Session.GetDefaultFolder(olFolderCalendar) .Items
Set objSafeApp = CreateObject("SafeOutlook.SecureAppointment")
Set objApp = objAppointments.Add
objApp.Save
objSafeApp.Item = objApp
Set colLinks = objSafeApp.Links
With objSafeApp
.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
Set objSafeApp.Item = Nothing
Set objSafeApp = Nothing

End Sub

Peter

On 7 Nov., 07:11, "Dmitry Streblechenko" wrote:
I can only suggest to use Redemption, which does not leave hanging
references...

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

"Peter Marchert" wrote in message

ups.com...



Thanks for your idea, Ken.

I`m sorry, but there is no change.

Peter

On 6 Nov., 21:47, "Ken Slovak - [MVP - Outlook]"
wrote:
Peter, see if this is any better:

Public objContacts As Outlook.Items
Public objContact As Outlook.ContactItem

Public objAppointments As Outlook.Items

Public objApp As Outlook.AppointmentItem
Public colLinks As Outlook.Links
Public objLink As Outlook.Link

Sub Test()
Dim oNS As Outlook.NameSpace

Set oNS = Outlook.GetNameSpace("MAPI")

Set objContacts = _
oNS.GetDefaultFolder(olFolderContacts).Items

Set objAppointments = _
oNS.GetDefaultFolder(olFolderCalendar).Items

Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)

Set objContacts = Nothing
Set objContact = Nothing

Set objAppointments = Nothing

Set objApp = Nothing
Set colLinks = Nothing
Set objLink = Nothing
End Sub

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts.Item(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next
End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)
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
End Sub

--
Ken Slovak
[MVP - Outlook]http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment
Optionshttp://www.slovaktech.com/products.htm

"Peter Marchert" wrote in message

groups.com...

Thank you Dmitry, but the error is still the

Sub Test()
Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)
End Sub

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

Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim lngIndex As Long

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next

End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link

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

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

End Sub

Peter- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -
  #23  
Old November 7th 07, 07:05 PM posted to microsoft.public.outlook.program_vba
Dmitry Streblechenko
external usenet poster
  
Posts: 1,592
Default Error when creating 247 appointments in exchange mailbox
I meant the RDO family of objects, which does not rely on OOM at all.
You will need to change the variable declarations appropriately and use
something like

set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Outlook.Session.MAPIOBJECT 'make them both use the
same session
set objContacts = Session.GetDefaultFolder(olFolderContacts).Items
set objAppointments =Session.GetDefaultFolder(olFolderCalendar).Items
....

Next version of Redemption will keep track of the open MAPI objects and
automatically release them when the number gets too high (they are
transparently reopened on demand), so you won't have to go through the
trouble of setting all objects to Nothing.
Send me an e-mail if you want a beta.

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

"Peter Marchert" wrote in message
ups.com...
How to do that? This code occurs the same error:

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link
Dim objSafeApp As Object

Set objAppointments =
Outlook.Session.GetDefaultFolder(olFolderCalendar) .Items
Set objSafeApp = CreateObject("SafeOutlook.SecureAppointment")
Set objApp = objAppointments.Add
objApp.Save
objSafeApp.Item = objApp
Set colLinks = objSafeApp.Links
With objSafeApp
.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
Set objSafeApp.Item = Nothing
Set objSafeApp = Nothing

End Sub

Peter

On 7 Nov., 07:11, "Dmitry Streblechenko" wrote:
I can only suggest to use Redemption, which does not leave hanging
references...

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

"Peter Marchert" wrote in message

ups.com...



Thanks for your idea, Ken.

I`m sorry, but there is no change.

Peter

On 6 Nov., 21:47, "Ken Slovak - [MVP - Outlook]"
wrote:
Peter, see if this is any better:

Public objContacts As Outlook.Items
Public objContact As Outlook.ContactItem

Public objAppointments As Outlook.Items

Public objApp As Outlook.AppointmentItem
Public colLinks As Outlook.Links
Public objLink As Outlook.Link

Sub Test()
Dim oNS As Outlook.NameSpace

Set oNS = Outlook.GetNameSpace("MAPI")

Set objContacts = _
oNS.GetDefaultFolder(olFolderContacts).Items

Set objAppointments = _
oNS.GetDefaultFolder(olFolderCalendar).Items

Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)

Set objContacts = Nothing
Set objContact = Nothing

Set objAppointments = Nothing

Set objApp = Nothing
Set colLinks = Nothing
Set objLink = Nothing
End Sub

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts.Item(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next
End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)
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
End Sub

--
Ken Slovak
[MVP - Outlook]http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment
Optionshttp://www.slovaktech.com/products.htm

"Peter Marchert" wrote in message

groups.com...

Thank you Dmitry, but the error is still the

Sub Test()
Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)
End Sub

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

Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim lngIndex As Long

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next

End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link

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

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

End Sub

Peter- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -
  #24  
Old November 8th 07, 10:08 AM posted to microsoft.public.outlook.program_vba
Peter Marchert
external usenet poster
  
Posts: 116
Default Error when creating 247 appointments in exchange mailbox
Thank you Dmitry, this works fine.

But I have another problem. In the code I create recurrence
appointments:

Set objRecPattern = .GetRecurrencePattern
objRecPattern.RecurrenceType = olRecursYearly
objRecPattern.PatternStartDate = dtmBirthday
objRecPattern.NoEndDate = True

With the OOM the description of the appointment is (translated) "This
appointment occurs every year on the 25th October, starting on 25th
October 2007" and no reminder comes up.

Same code with RDO (objRecPattern then is dimed as object not longer
as Outlook.RecurrencePattern) set the description to "This appointment
occurs every year on the 25th October, in the period from 25.10.2007
to 02.01.4501." and a reminder comes up. So may be I have to set one
more parameter in RDO?

Peter

On 7 Nov., 19:05, "Dmitry Streblechenko" wrote:
I meant the RDO family of objects, which does not rely on OOM at all.
You will need to change the variable declarations appropriately and use
something like

set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Outlook.Session.MAPIOBJECT 'make them both use the
same session
set objContacts = Session.GetDefaultFolder(olFolderContacts).Items
set objAppointments =Session.GetDefaultFolder(olFolderCalendar).Items
...

Next version of Redemption will keep track of the open MAPI objects and
automatically release them when the number gets too high (they are
transparently reopened on demand), so you won't have to go through the
trouble of setting all objects to Nothing.
Send me an e-mail if you want a beta.

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

"Peter Marchert" wrote in message

ups.com...



How to do that? This code occurs the same error:

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link
Dim objSafeApp As Object

Set objAppointments =
Outlook.Session.GetDefaultFolder(olFolderCalendar) .Items
Set objSafeApp = CreateObject("SafeOutlook.SecureAppointment")
Set objApp = objAppointments.Add
objApp.Save
objSafeApp.Item = objApp
Set colLinks = objSafeApp.Links
With objSafeApp
.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
Set objSafeApp.Item = Nothing
Set objSafeApp = Nothing

End Sub

Peter

On 7 Nov., 07:11, "Dmitry Streblechenko" wrote:
I can only suggest to use Redemption, which does not leave hanging
references...

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

"Peter Marchert" wrote in message

roups.com...

Thanks for your idea, Ken.

I`m sorry, but there is no change.

Peter

On 6 Nov., 21:47, "Ken Slovak - [MVP - Outlook]"
wrote:
Peter, see if this is any better:

Public objContacts As Outlook.Items
Public objContact As Outlook.ContactItem

Public objAppointments As Outlook.Items

Public objApp As Outlook.AppointmentItem
Public colLinks As Outlook.Links
Public objLink As Outlook.Link

Sub Test()
Dim oNS As Outlook.NameSpace

Set oNS = Outlook.GetNameSpace("MAPI")

Set objContacts = _
oNS.GetDefaultFolder(olFolderContacts).Items

Set objAppointments = _
oNS.GetDefaultFolder(olFolderCalendar).Items

Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)

Set objContacts = Nothing
Set objContact = Nothing

Set objAppointments = Nothing

Set objApp = Nothing
Set colLinks = Nothing
Set objLink = Nothing
End Sub

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts.Item(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next
End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)
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
End Sub

--
Ken Slovak
[MVP - Outlook]http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment
Optionshttp://www.slovaktech.com/products.htm

"Peter Marchert" wrote in message

groups.com...

Thank you Dmitry, but the error is still the

Sub Test()
Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)
End Sub

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

Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim lngIndex As Long

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next

End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link

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

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

End Sub

Peter- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -
  #25  
Old November 8th 07, 06:28 PM posted to microsoft.public.outlook.program_vba
Dmitry Streblechenko
external usenet poster
  
Posts: 1,592
Default Error when creating 247 appointments in exchange mailbox
Try to set RDOAppointmentItem.ReminderSet to false

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

"Peter Marchert" wrote in message
ups.com...
Thank you Dmitry, this works fine.

But I have another problem. In the code I create recurrence
appointments:

Set objRecPattern = .GetRecurrencePattern
objRecPattern.RecurrenceType = olRecursYearly
objRecPattern.PatternStartDate = dtmBirthday
objRecPattern.NoEndDate = True

With the OOM the description of the appointment is (translated) "This
appointment occurs every year on the 25th October, starting on 25th
October 2007" and no reminder comes up.

Same code with RDO (objRecPattern then is dimed as object not longer
as Outlook.RecurrencePattern) set the description to "This appointment
occurs every year on the 25th October, in the period from 25.10.2007
to 02.01.4501." and a reminder comes up. So may be I have to set one
more parameter in RDO?

Peter

On 7 Nov., 19:05, "Dmitry Streblechenko" wrote:
I meant the RDO family of objects, which does not rely on OOM at all.
You will need to change the variable declarations appropriately and use
something like

set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Outlook.Session.MAPIOBJECT 'make them both use the
same session
set objContacts = Session.GetDefaultFolder(olFolderContacts).Items
set objAppointments =Session.GetDefaultFolder(olFolderCalendar).Items
...

Next version of Redemption will keep track of the open MAPI objects and
automatically release them when the number gets too high (they are
transparently reopened on demand), so you won't have to go through the
trouble of setting all objects to Nothing.
Send me an e-mail if you want a beta.

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

"Peter Marchert" wrote in message

ups.com...



How to do that? This code occurs the same error:

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link
Dim objSafeApp As Object

Set objAppointments =
Outlook.Session.GetDefaultFolder(olFolderCalendar) .Items
Set objSafeApp = CreateObject("SafeOutlook.SecureAppointment")
Set objApp = objAppointments.Add
objApp.Save
objSafeApp.Item = objApp
Set colLinks = objSafeApp.Links
With objSafeApp
.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
Set objSafeApp.Item = Nothing
Set objSafeApp = Nothing

End Sub

Peter

On 7 Nov., 07:11, "Dmitry Streblechenko" wrote:
I can only suggest to use Redemption, which does not leave hanging
references...

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

"Peter Marchert" wrote in message

roups.com...

Thanks for your idea, Ken.

I`m sorry, but there is no change.

Peter

On 6 Nov., 21:47, "Ken Slovak - [MVP - Outlook]"

wrote:
Peter, see if this is any better:

Public objContacts As Outlook.Items
Public objContact As Outlook.ContactItem

Public objAppointments As Outlook.Items

Public objApp As Outlook.AppointmentItem
Public colLinks As Outlook.Links
Public objLink As Outlook.Link

Sub Test()
Dim oNS As Outlook.NameSpace

Set oNS = Outlook.GetNameSpace("MAPI")

Set objContacts = _
oNS.GetDefaultFolder(olFolderContacts).Items

Set objAppointments = _
oNS.GetDefaultFolder(olFolderCalendar).Items

Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)

Set objContacts = Nothing
Set objContact = Nothing

Set objAppointments = Nothing

Set objApp = Nothing
Set colLinks = Nothing
Set objLink = Nothing
End Sub

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts.Item(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next
End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)
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
End Sub

--
Ken Slovak
[MVP - Outlook]http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment
Optionshttp://www.slovaktech.com/products.htm

"Peter Marchert" wrote in message

groups.com...

Thank you Dmitry, but the error is still the

Sub Test()
Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)
End Sub

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

Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim lngIndex As Long

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next

End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link

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

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

End Sub

Peter- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -
  #26  
Old November 8th 07, 07:25 PM posted to microsoft.public.outlook.program_vba
Peter Marchert
external usenet poster
  
Posts: 116
Default Error when creating 247 appointments in exchange mailbox
The reminder should not be deactivated, but not appear when creating
the items. With the code for OOM this is ok, with the same code in RDO
the description of the appointments is different and the reminder for
all created items appears. I think there is the problem. Why could
this be if the code is the same?

Peter

On 8 Nov., 18:28, "Dmitry Streblechenko" wrote:
Try to set RDOAppointmentItem.ReminderSet to false

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

"Peter Marchert" wrote in message

ups.com...



Thank you Dmitry, this works fine.

But I have another problem. In the code I create recurrence
appointments:

Set objRecPattern = .GetRecurrencePattern
objRecPattern.RecurrenceType = olRecursYearly
objRecPattern.PatternStartDate = dtmBirthday
objRecPattern.NoEndDate = True

With the OOM the description of the appointment is (translated) "This
appointment occurs every year on the 25th October, starting on 25th
October 2007" and no reminder comes up.

Same code with RDO (objRecPattern then is dimed as object not longer
as Outlook.RecurrencePattern) set the description to "This appointment
occurs every year on the 25th October, in the period from 25.10.2007
to 02.01.4501." and a reminder comes up. So may be I have to set one
more parameter in RDO?

Peter

On 7 Nov., 19:05, "Dmitry Streblechenko" wrote:
I meant the RDO family of objects, which does not rely on OOM at all.
You will need to change the variable declarations appropriately and use
something like

set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Outlook.Session.MAPIOBJECT 'make them both use the
same session
set objContacts = Session.GetDefaultFolder(olFolderContacts).Items
set objAppointments =Session.GetDefaultFolder(olFolderCalendar).Items
...

Next version of Redemption will keep track of the open MAPI objects and
automatically release them when the number gets too high (they are
transparently reopened on demand), so you won't have to go through the
trouble of setting all objects to Nothing.
Send me an e-mail if you want a beta.

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

"Peter Marchert" wrote in message

roups.com...

How to do that? This code occurs the same error:

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link
Dim objSafeApp As Object

Set objAppointments =
Outlook.Session.GetDefaultFolder(olFolderCalendar) .Items
Set objSafeApp = CreateObject("SafeOutlook.SecureAppointment")
Set objApp = objAppointments.Add
objApp.Save
objSafeApp.Item = objApp
Set colLinks = objSafeApp.Links
With objSafeApp
.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
Set objSafeApp.Item = Nothing
Set objSafeApp = Nothing

End Sub

Peter

On 7 Nov., 07:11, "Dmitry Streblechenko" wrote:
I can only suggest to use Redemption, which does not leave hanging
references...

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

"Peter Marchert" wrote in message

roups.com...

Thanks for your idea, Ken.

I`m sorry, but there is no change.

Peter

On 6 Nov., 21:47, "Ken Slovak - [MVP - Outlook]"

wrote:
Peter, see if this is any better:

Public objContacts As Outlook.Items
Public objContact As Outlook.ContactItem

Public objAppointments As Outlook.Items

Public objApp As Outlook.AppointmentItem
Public colLinks As Outlook.Links
Public objLink As Outlook.Link

Sub Test()
Dim oNS As Outlook.NameSpace

Set oNS = Outlook.GetNameSpace("MAPI")

Set objContacts = _
oNS.GetDefaultFolder(olFolderContacts).Items

Set objAppointments = _
oNS.GetDefaultFolder(olFolderCalendar).Items

Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)

Set objContacts = Nothing
Set objContact = Nothing

Set objAppointments = Nothing

Set objApp = Nothing
Set colLinks = Nothing
Set objLink = Nothing
End Sub

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts.Item(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next
End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)
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
End Sub

--
Ken Slovak
[MVP - Outlook]http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment
Optionshttp://www.slovaktech.com/products.htm

"Peter Marchert" wrote in message

groups.com...

Thank you Dmitry, but the error is still the

Sub Test()
Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)
End Sub

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

Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim lngIndex As Long

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next

End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link

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

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

End Sub

Peter- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -
  #27  
Old November 8th 07, 09:35 PM posted to microsoft.public.outlook.program_vba
Dmitry Streblechenko
external usenet poster
  
Posts: 1,592
Default Error when creating 247 appointments in exchange mailbox
I am not sure what you mean by "but not appear when creating the items".
Do you mean it shoudl nto appear while your codei is still running in a loop
creating items? Why shouldn't Outlook display a reminder?
I would imagine if you are using OOM, it physically cannot do so since it is
busy with your script, but RDO does not use Outlook, so it is free to
display a reminder.
As for the recurrence description, what version of Redemption are you using?

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

"Peter Marchert" wrote in message
ups.com...
The reminder should not be deactivated, but not appear when creating
the items. With the code for OOM this is ok, with the same code in RDO
the description of the appointments is different and the reminder for
all created items appears. I think there is the problem. Why could
this be if the code is the same?

Peter

On 8 Nov., 18:28, "Dmitry Streblechenko" wrote:
Try to set RDOAppointmentItem.ReminderSet to false

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

"Peter Marchert" wrote in message

ups.com...



Thank you Dmitry, this works fine.

But I have another problem. In the code I create recurrence
appointments:

Set objRecPattern = .GetRecurrencePattern
objRecPattern.RecurrenceType = olRecursYearly
objRecPattern.PatternStartDate = dtmBirthday
objRecPattern.NoEndDate = True

With the OOM the description of the appointment is (translated) "This
appointment occurs every year on the 25th October, starting on 25th
October 2007" and no reminder comes up.

Same code with RDO (objRecPattern then is dimed as object not longer
as Outlook.RecurrencePattern) set the description to "This appointment
occurs every year on the 25th October, in the period from 25.10.2007
to 02.01.4501." and a reminder comes up. So may be I have to set one
more parameter in RDO?

Peter

On 7 Nov., 19:05, "Dmitry Streblechenko" wrote:
I meant the RDO family of objects, which does not rely on OOM at all.
You will need to change the variable declarations appropriately and
use
something like

set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Outlook.Session.MAPIOBJECT 'make them both use
the
same session
set objContacts = Session.GetDefaultFolder(olFolderContacts).Items
set objAppointments =Session.GetDefaultFolder(olFolderCalendar).Items
...

Next version of Redemption will keep track of the open MAPI objects
and
automatically release them when the number gets too high (they are
transparently reopened on demand), so you won't have to go through the
trouble of setting all objects to Nothing.
Send me an e-mail if you want a beta.

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

"Peter Marchert" wrote in message

roups.com...

How to do that? This code occurs the same error:

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link
Dim objSafeApp As Object

Set objAppointments =
Outlook.Session.GetDefaultFolder(olFolderCalendar) .Items
Set objSafeApp = CreateObject("SafeOutlook.SecureAppointment")
Set objApp = objAppointments.Add
objApp.Save
objSafeApp.Item = objApp
Set colLinks = objSafeApp.Links
With objSafeApp
.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
Set objSafeApp.Item = Nothing
Set objSafeApp = Nothing

End Sub

Peter

On 7 Nov., 07:11, "Dmitry Streblechenko" wrote:
I can only suggest to use Redemption, which does not leave hanging
references...

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

"Peter Marchert" wrote in message

roups.com...

Thanks for your idea, Ken.

I`m sorry, but there is no change.

Peter

On 6 Nov., 21:47, "Ken Slovak - [MVP - Outlook]"

wrote:
Peter, see if this is any better:

Public objContacts As Outlook.Items
Public objContact As Outlook.ContactItem

Public objAppointments As Outlook.Items

Public objApp As Outlook.AppointmentItem
Public colLinks As Outlook.Links
Public objLink As Outlook.Link

Sub Test()
Dim oNS As Outlook.NameSpace

Set oNS = Outlook.GetNameSpace("MAPI")

Set objContacts = _
oNS.GetDefaultFolder(olFolderContacts).Items

Set objAppointments = _
oNS.GetDefaultFolder(olFolderCalendar).Items

Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)

Set objContacts = Nothing
Set objContact = Nothing

Set objAppointments = Nothing

Set objApp = Nothing
Set colLinks = Nothing
Set objLink = Nothing
End Sub

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts.Item(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next
End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)
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
End Sub

--
Ken Slovak
[MVP - Outlook]http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment
Optionshttp://www.slovaktech.com/products.htm

"Peter Marchert" wrote in message

groups.com...

Thank you Dmitry, but the error is still the

Sub Test()
Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)
End Sub

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

Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim lngIndex As Long

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next

End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link

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

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

End Sub

Peter- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -- Zitierten Text ausblenden -

- Zitierten Text anzeigen -
  #28  
Old November 9th 07, 08:51 AM posted to microsoft.public.outlook.program_vba
Peter Marchert
external usenet poster
  
Posts: 116
Default Error when creating 247 appointments in exchange mailbox
You can see what I mean, if you use the following code:

Sub CreateAppointments()

Dim objSession As Object
Dim objAppointments As Object
Dim objAppointment As Object

Set objSession = CreateObject("Redemption.RDOSession")
objSession.MAPIOBJECT = Outlook.Session.MAPIOBJECT

Set objAppointment =
objSession.GetDefaultFolder(olFolderCalendar).Item s.Add

With objAppointment
.ReminderSet = True
.Subject = "Test"
.AllDayEvent = True
.Start = Date - 5
Set objRecPattern = .GetRecurrencePattern
objRecPattern.RecurrenceType = olRecursYearly
objRecPattern.PatternStartDate = Date - 5
objRecPattern.NoEndDate = True
.Save
End With

End Sub

A reminder comes up from midnight of the last day.

Redemption version is 4.5.0.730.

Peter

On 8 Nov., 21:35, "Dmitry Streblechenko" wrote:
I am not sure what you mean by "but not appear when creating the items".
Do you mean it shoudl nto appear while your codei is still running in a loop
creating items? Why shouldn't Outlook display a reminder?
I would imagine if you are using OOM, it physically cannot do so since it is
busy with your script, but RDO does not use Outlook, so it is free to
display a reminder.
As for the recurrence description, what version of Redemption are you using?

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

"Peter Marchert" wrote in message

ups.com...



The reminder should not be deactivated, but not appear when creating
the items. With the code for OOM this is ok, with the same code in RDO
the description of the appointments is different and the reminder for
all created items appears. I think there is the problem. Why could
this be if the code is the same?

Peter

On 8 Nov., 18:28, "Dmitry Streblechenko" wrote:
Try to set RDOAppointmentItem.ReminderSet to false

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

"Peter Marchert" wrote in message

roups.com...

Thank you Dmitry, this works fine.

But I have another problem. In the code I create recurrence
appointments:

Set objRecPattern = .GetRecurrencePattern
objRecPattern.RecurrenceType = olRecursYearly
objRecPattern.PatternStartDate = dtmBirthday
objRecPattern.NoEndDate = True

With the OOM the description of the appointment is (translated) "This
appointment occurs every year on the 25th October, starting on 25th
October 2007" and no reminder comes up.

Same code with RDO (objRecPattern then is dimed as object not longer
as Outlook.RecurrencePattern) set the description to "This appointment
occurs every year on the 25th October, in the period from 25.10.2007
to 02.01.4501." and a reminder comes up. So may be I have to set one
more parameter in RDO?

Peter

On 7 Nov., 19:05, "Dmitry Streblechenko" wrote:
I meant the RDO family of objects, which does not rely on OOM at all.
You will need to change the variable declarations appropriately and
use
something like

set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Outlook.Session.MAPIOBJECT 'make them both use
the
same session
set objContacts = Session.GetDefaultFolder(olFolderContacts).Items
set objAppointments =Session.GetDefaultFolder(olFolderCalendar).Items
...

Next version of Redemption will keep track of the open MAPI objects
and
automatically release them when the number gets too high (they are
transparently reopened on demand), so you won't have to go through the
trouble of setting all objects to Nothing.
Send me an e-mail if you want a beta.

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

"Peter Marchert" wrote in message

roups.com...

How to do that? This code occurs the same error:

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link
Dim objSafeApp As Object

Set objAppointments =
Outlook.Session.GetDefaultFolder(olFolderCalendar) .Items
Set objSafeApp = CreateObject("SafeOutlook.SecureAppointment")
Set objApp = objAppointments.Add
objApp.Save
objSafeApp.Item = objApp
Set colLinks = objSafeApp.Links
With objSafeApp
.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
Set objSafeApp.Item = Nothing
Set objSafeApp = Nothing

End Sub

Peter

On 7 Nov., 07:11, "Dmitry Streblechenko" wrote:
I can only suggest to use Redemption, which does not leave hanging
references...

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

"Peter Marchert" wrote in message

roups.com...

Thanks for your idea, Ken.

I`m sorry, but there is no change.

Peter

On 6 Nov., 21:47, "Ken Slovak - [MVP - Outlook]"

wrote:
Peter, see if this is any better:

Public objContacts As Outlook.Items
Public objContact As Outlook.ContactItem

Public objAppointments As Outlook.Items

Public objApp As Outlook.AppointmentItem
Public colLinks As Outlook.Links
Public objLink As Outlook.Link

Sub Test()
Dim oNS As Outlook.NameSpace

Set oNS = Outlook.GetNameSpace("MAPI")

Set objContacts = _
oNS.GetDefaultFolder(olFolderContacts).Items

Set objAppointments = _
oNS.GetDefaultFolder(olFolderCalendar).Items

Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)

Set objContacts = Nothing
Set objContact = Nothing

Set objAppointments = Nothing

Set objApp = Nothing
Set colLinks = Nothing
Set objLink = Nothing
End Sub

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts.Item(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next
End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)
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
End Sub

--
Ken Slovak
[MVP - Outlook]http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment
Optionshttp://www.slovaktech.com/products.htm

"Peter Marchert" wrote in message

groups.com...

Thank you Dmitry, but the error is still the

Sub Test()
Call CreateAppointments(1, 230)
Call CreateAppointments(231, 400)
End Sub

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

Dim objContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim lngIndex As Long

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

For lngIndex = lngFrom To lngTo
Set objContact = objContacts(lngIndex)
Call AddAppointment(objContact)
Set objContact = Nothing
Next

End Sub

Sub AddAppointment(ByVal objContact As Outlook.ContactItem)

Dim objAppointments As Outlook.Items
Dim objApp As Outlook.AppointmentItem
Dim colLinks As Outlook.Links
Dim objLink As Outlook.Link