VBA: Problem in Iterating Recurring meeting

[masani paresh]

Hi Friends,

I have been in trouble since long in below issue. Please refer below
complete code: It works on some machine but not others. I have mentioned
problem after the macro.

Sub ApptWithNotesOnDelete()

Dim olkOldAppt As Outlook.AppointmentItem, _
olkItems As Outlook.Items, _
olkThisSeries As Outlook.Items, _
olkNewAppt As Outlook.AppointmentItem

Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set olkOldAppt = Application.ActiveExplorer.Selection(1)
Case "Inspector"
Set olkOldAppt = Application.ActiveInspector.CurrentItem
End Select

Set olkItems = Session.GetDefaultFolder(olFolderCalendar).Items
olkItems.Sort "[Start]"
olkItems.IncludeRecurrences = True

Set olkThisSeries = olkItems.Restrict("[Subject] = '" &
olkOldAppt.Subject & "'")

For Each olkAppt In olkThisSeries
MsgBox olkAppt.Start
If CDate(Date) < CDate(DateValue(olkAppt.Start)) Then Exit For
Set olkNewAppt = Application.CreateItem(olAppointmentItem)
With olkNewAppt
.Start = olkAppt.Start
.End = olkAppt.End
.Subject = olkAppt.Subject
.Body = olkAppt.Body
.Location = olkAppt.Location
.ReminderSet = olkAppt.ReminderSet
.BusyStatus = olkAppt.BusyStatus
.Save
End With
Next
olkOldAppt.Delete

Set olkNewAppt = Nothing
Set olkThisSeries = Nothing
Set olkItems = Nothing
Set olkOldAppt = Nothing
End Sub

The problem is in below for loop. It goes in infinite loop on some machine
because it never proceed to next meeting in the recurring series and always
stays at the first meeting and that leads to create infinite meetings and
macro gets terminated abnormally. It works fine on some machine.

For Each olkAppt In olkThisSeries
MsgBox olkAppt.Start
If CDate(Date) < CDate(DateValue(olkAppt.Start)) Then Exit For
Set olkNewAppt = Application.CreateItem(olAppointmentItem)
With olkNewAppt
.Start = olkAppt.Start
.End = olkAppt.End
.Subject = olkAppt.Subject
.Body = olkAppt.Body
.Location = olkAppt.Location
.ReminderSet = olkAppt.ReminderSet
.BusyStatus = olkAppt.BusyStatus
.Save
End With
Next

Any helps on this issue will be much appreciated.

Thanks in advance,
Paresh

 

[Alan Moseley]

If the recurrence has been set with 'No End Date' then you will find yourself
in an infinite loop. You will either need to limit this recurrence in some
way, eg by date, or not include recurring items.

 

[masani paresh]

Thanks for reply.

I wont be in infinite loop because of recurring meeting which has no end
date because of " If CDate(Date) < CDate(DateValue(olkAppt.Start)) Then Exit
For" condition is being checked in macro. That is not a problem either. The
problem is in For Each look the olkAppt object always stays at first meeting
items(for example on 2nd Jan) and it never goes to next item. I also tried
with While loop and using Set olkAppt = olkThisSeries.GetNext() but same
behaviour. Its really a strange behaviour.

Thanks,
Paresh

If the recurrence has been set with 'No End Date' then you will find yourself
in an infinite loop. You will either need to limit this recurrence in some
way, eg by date, or not include recurring items.
--
Alan Moseley IT Consultancy
http://www.amitc.co.uk

If I have solved your problem, please click Yes below. Thanks.

Hi Friends,

I have been in trouble since long in below issue. Please refer below
complete code: It works on some machine but not others. I have mentioned
problem after the macro.

Sub ApptWithNotesOnDelete()

Dim olkOldAppt As Outlook.AppointmentItem, _
olkItems As Outlook.Items, _
olkThisSeries As Outlook.Items, _
olkNewAppt As Outlook.AppointmentItem

Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set olkOldAppt = Application.ActiveExplorer.Selection(1)
Case "Inspector"
Set olkOldAppt = Application.ActiveInspector.CurrentItem
End Select

Set olkItems = Session.GetDefaultFolder(olFolderCalendar).Items
olkItems.Sort "[Start]"
olkItems.IncludeRecurrences = True

Set olkThisSeries = olkItems.Restrict("[Subject] = '" &
olkOldAppt.Subject & "'")

For Each olkAppt In olkThisSeries
MsgBox olkAppt.Start
If CDate(Date) < CDate(DateValue(olkAppt.Start)) Then Exit For
Set olkNewAppt = Application.CreateItem(olAppointmentItem)
With olkNewAppt
.Start = olkAppt.Start
.End = olkAppt.End
.Subject = olkAppt.Subject
.Body = olkAppt.Body
.Location = olkAppt.Location
.ReminderSet = olkAppt.ReminderSet
.BusyStatus = olkAppt.BusyStatus
.Save
End With
Next
olkOldAppt.Delete

Set olkNewAppt = Nothing
Set olkThisSeries = Nothing
Set olkItems = Nothing
Set olkOldAppt = Nothing
End Sub

The problem is in below for loop. It goes in infinite loop on some machine
because it never proceed to next meeting in the recurring series and always
stays at the first meeting and that leads to create infinite meetings and
macro gets terminated abnormally. It works fine on some machine.

For Each olkAppt In olkThisSeries
MsgBox olkAppt.Start
If CDate(Date) < CDate(DateValue(olkAppt.Start)) Then Exit For
Set olkNewAppt = Application.CreateItem(olAppointmentItem)
With olkNewAppt
.Start = olkAppt.Start
.End = olkAppt.End
.Subject = olkAppt.Subject
.Body = olkAppt.Body
.Location = olkAppt.Location
.ReminderSet = olkAppt.ReminderSet
.BusyStatus = olkAppt.BusyStatus
.Save
End With
Next

Any helps on this issue will be much appreciated.

Thanks in advance,
Paresh

 

[Ken Slovak - [MVP - Outlook]]

See the discussion at http://www.outlookcode.com/codedetail.aspx?id=1206 and
see if that helps you.