Outlook crashes on VBA code completion

[Cameron Gray]

Hi,

This is a follow up to my email about changing the end date of recurrences
without losing exceptions. I have written the following code, but
unfortunately whenever it is run against a recurring meeting (either with or
without exceptions) where there are attendees (it works fine on
appointments). Outlook 2000 hangs with the XP "an error has occured... send
to microsoft?" messages. Then promptly closes. (The changes all get made and
saved).

It gets all the way to the msgbox "All Done" statement at the very end
before dying.

Any help? Suggestions?

Cheers,
Cameron.

Option Explicit
Type ExceptionInformation
Deleted As Boolean
OriginalDate As Date
AllDayEvent As Boolean
Body As String
BusyStatus As Long
End As Date
Importance As Long
Location As String
OptionalAttendees As String
ReminderMinutesBeforeStart As Long
ReminderSet As Boolean
RequiredAttendees As String
Start As Date
Subject As String
Recipients As New Collection
End Type

Public Sub Main_ChangeRecurrenceEndDate_Inspector()

Dim itmItem As AppointmentItem

If TypeName(ActiveWindow) <> "Inspector" Then
MsgBox "Currently only works on an inspector window."
Exit Sub
End If
If ActiveInspector.CurrentItem.Class <> 26 Then 'Need to check it's an
appointment item before setting a variable
MsgBox "Currently only works on an AppointmentItem (or Meeting)"
Exit Sub
End If

Set itmItem = ActiveInspector.CurrentItem

If itmItem.RecurrenceState <> 1 Then
MsgBox "This is item is either not a recurring item or is an exception
to the pattern or you chose to open this instance not the series. (May be
able to work on exceptions later)"
Exit Sub
End If
If Not itmItem.Saved Then
MsgBox "You must save any other changes before trying to change the end
date of teh recurrence"
Exit Sub
End If
If itmItem.MeetingStatus <> olNonMeeting And itmItem.MeetingStatus <>
olMeeting Then
MsgBox "Can not change meetings that you did not organise."
Exit Sub
End If

If itmItem.GetRecurrencePattern.Exceptions.Count > 0 Then
ChangeRecurrenceWithException
Else
ChangeRecurrenceNoException
End If

MsgBox "All Done!"

End Sub

Private Sub ChangeRecurrenceNoException()

Dim strNewEndDate As String
Dim dteNewEndDate As Date
Dim recRecur As RecurrencePattern
Dim itmItem As AppointmentItem
Set itmItem = ActiveInspector.CurrentItem

If MsgBox("Are you sure you want to change the end date of this recurring
item?" & vbCrLf & "(This action can't be undone)", vbYesNo + vbExclamation,
"Confirm change to recurrence") <> vbYes Then Exit Sub
strNewEndDate = InputBox("Please provide new end date for recurrence.", "New
End Date",
ActiveExplorer.Selection.Item(1).GetRecurrencePattern.PatternEndDate)
If strNewEndDate = "" Then
Exit Sub
End If
dteNewEndDate = DateValue(strNewEndDate)
Set recRecur = itmItem.GetRecurrencePattern
If dteNewEndDate < recRecur.PatternStartDate Then
MsgBox "Date Provided is invalid."
Exit Sub
End If
recRecur.PatternEndDate = dteNewEndDate
If itmItem.MeetingStatus = olNonMeeting Then
itmItem.Save
itmItem.Close olDiscard
Else
itmItem.Send
End If

End Sub
Private Sub ChangeRecurrenceWithException()

Dim strNewEndDate As String
Dim dteNewEndDate As Date
Dim recRecur As RecurrencePattern
Dim itmItem As AppointmentItem
Set itmItem = ActiveInspector.CurrentItem
Dim excExceptions() As ExceptionInformation
Dim inta As Integer 'For lopping
Dim itmExceptionDetails As AppointmentItem
Dim dteTemp As Date
Dim recTemp As Recipient

'Confirm user understands implication of change
If MsgBox("This only maintains key information items for exceptions." &
vbCrLf & "Are you sure you want to change the end date of this recurring
item?" & vbCrLf & "(This action can't be undone)", vbYesNo + vbExclamation,
"Confirm change to recurrence") <> vbYes Then Exit Sub

'Get and validate the new end date
strNewEndDate = InputBox("Please provide new end date for recurrence.", "New
End Date",
ActiveExplorer.Selection.Item(1).GetRecurrencePattern.PatternEndDate)
If strNewEndDate = "" Then
Exit Sub
End If
dteNewEndDate = DateValue(strNewEndDate)
Set recRecur = itmItem.GetRecurrencePattern
If dteNewEndDate < recRecur.PatternStartDate Then
MsgBox "Date Provided is invalid."
Exit Sub
End If

'Backup Exceptions
For inta = 1 To recRecur.Exceptions.Count
If Not recRecur.Exceptions.Item(inta).Deleted Then
If recRecur.Exceptions.Item(inta).AppointmentItem.Attachments.Count

0 Then

MsgBox "Attachments on exceptions causes a failure."
Exit Sub
End If
End If
Next inta

ReDim excExceptions(1 To recRecur.Exceptions.Count)
For inta = 1 To recRecur.Exceptions.Count
excExceptions(inta).OriginalDate =
recRecur.Exceptions.Item(inta).OriginalDate
excExceptions(inta).Deleted = recRecur.Exceptions.Item(inta).Deleted
If Not recRecur.Exceptions.Item(inta).Deleted Then 'Only get these
details if there is a valid exception item
Set itmExceptionDetails =
recRecur.Exceptions.Item(inta).AppointmentItem
excExceptions(inta).AllDayEvent = itmExceptionDetails.AllDayEvent
excExceptions(inta).Body = "End date of the recurring series was
changed. This is an update to ensure histroy is not lost. Please accept." &
vbCrLf & vbCrLf & itmExceptionDetails.Body
excExceptions(inta).BusyStatus = itmExceptionDetails.BusyStatus
excExceptions(inta).End = itmExceptionDetails.End
excExceptions(inta).Importance = itmExceptionDetails.Importance
excExceptions(inta).Location = itmExceptionDetails.Location
excExceptions(inta).ReminderMinutesBeforeStart =
itmExceptionDetails.ReminderMinutesBeforeStart
excExceptions(inta).ReminderSet = itmExceptionDetails.ReminderSet
excExceptions(inta).Start = itmExceptionDetails.Start
excExceptions(inta).Subject = itmExceptionDetails.Subject
If excExceptions(inta).RequiredAttendees = itmItem.RequiredAttendees
And excExceptions(inta).OptionalAttendees = itmItem.OptionalAttendees Then
excExceptions(inta).RequiredAttendees = "No Changes"
excExceptions(inta).OptionalAttendees = "No Changes"
Else
For Each recTemp In itmExceptionDetails.Recipients
excExceptions(inta).Recipients.Add Item:=recTemp
Next recTemp
End If
End If
Next inta

'Change the end Date
recRecur.PatternEndDate = dteNewEndDate
If itmItem.MeetingStatus = olNonMeeting Then
itmItem.Save
itmExceptionDetails.Close olDiscard
Else
If MsgBox("There are " & UBound(excExceptions) & "exceptions collected.
Your new end date represents " & recRecur.Occurrences & "recurrences." &
vbCrLf & "Do you wish to continue?", vbYesNo + vbQuestion) = vbNo Then
itmItem.Close olDiscard
Exit Sub
End If
itmItem.Send
End If

'Restore and exceptions that are valid
For inta = 1 To UBound(excExceptions)
dteTemp = excExceptions(inta).OriginalDate
If Not DateSerial(Year(dteTemp), Month(dteTemp), Day(dteTemp)) >
DateSerial(Year(dteNewEndDate), Month(dteNewEndDate), Day(dteNewEndDate))
Then 'Only restore exceptions that still occur in timeframes of the pattern
On Error Resume Next
Set itmExceptionDetails =
recRecur.GetOccurrence(excExceptions(inta).OriginalDate)
If Err.Number = 0 Then
If excExceptions(inta).Deleted = True Then
itmExceptionDetails.Delete
Else
itmExceptionDetails.Display
itmExceptionDetails.AllDayEvent =
excExceptions(inta).AllDayEvent
itmExceptionDetails.Body = excExceptions(inta).Body
itmExceptionDetails.BusyStatus =
excExceptions(inta).BusyStatus
itmExceptionDetails.Start = excExceptions(inta).Start
itmExceptionDetails.End = excExceptions(inta).End
itmExceptionDetails.Importance =
excExceptions(inta).Importance
itmExceptionDetails.Location = excExceptions(inta).Location
itmExceptionDetails.ReminderMinutesBeforeStart =
excExceptions(inta).ReminderMinutesBeforeStart
If itmExceptionDetails.Start >= Now() Then
itmExceptionDetails.ReminderSet =
excExceptions(inta).ReminderSet
Else
itmExceptionDetails.ReminderSet = False
End If
itmExceptionDetails.Subject = excExceptions(inta).Subject
If Not excExceptions(inta).RequiredAttendees = "No Changes"
And excExceptions(inta).OptionalAttendees = "No Changes" Then
For Each recTemp In itmExceptionDetails.Recipients
recTemp.Delete
Next recTemp
For Each recTemp In excExceptions(inta).Recipients
itmExceptionDetails.Recipients.Add
Name:=recTemp.Name
itmExceptionDetails.Recipients.Item(recTemp.Name) =
recTemp.Name
Next recTemp
End If
If itmExceptionDetails.MeetingStatus = olNonMeeting Then
itmExceptionDetails.Save
itmExceptionDetails.Close olDiscard
Else
itmExceptionDetails.Send
End If
End If
Else
MsgBox "Exception on " & excExceptions(inta).OriginalDate & "
was missed as it no longer exists."
End If
On Error GoTo 0
End If
Next inta

End Sub

 

[Kasey Quanrud [MS]]

I ran the code on Outlook 2000 and I get the same crash, a page fault.
However, I also ran the code on Outlook 2003 and it did not crash. I'm
investigating if Outlook 2000 has any known issues that could cause this.

~Kasey

 

[Guest]

Hi,

I've got a similar question......

But I'm not experienced in using office at the "progammers-level"....sorry..!!! So I don't understand much of what's been dealt with in this thread...

So could you explain for a "simple"office user.....how I can perform a search in Outlook to find exceptions of a recurring meeting?

Trudie

 

[Sue Mosher [MVP]]

There is no way for a simple office user to locate meeting recurrence exceptions.
--
Sue Mosher, Outlook MVP
Outlook and Exchange solutions at http://www.slipstick.com
Author of
Microsoft Outlook Programming: Jumpstart
for Administrators, Power Users, and Developers