Excel VBA hangs accessing Outlook on one computer, but not another.

DavidLambert

New Member
Joined
May 24, 2021
Messages
2
Office Version
  1. 2019
Platform
  1. Windows
I have an Excel VBA macro that's reading Appointments in Outlook, and it hangs on one computer, but not the other. There is one major difference between the two computers:
On my computer, Outlook runs standalone, and the macro runs flawlessly.
On another person's computer, Outlook connects to an Exchange Server, and Excel locks up and displays this message: "Microsoft Excel is waiting for another application to complete an OLE action."
This difference might be irrelevant, but I think it's worth mentioning up front.

The problem line is the line where I'm accessing the Exception object of a recurring appointment that has not been deleted:
Set oAppointmentItemExcept = oException.appointmentItem
If I remove that line and later lines that depend on it, then the macro completes without error.

Here's a stripped-down version of the module that reproduces this issue.

Any feedback would be appreciated. Thank you.

VBA Code:
Option Explicit

Sub ExtractFromCalendar()
    Const olFolderCalendar       As Integer = 9
    Const iDateColumn            As Integer = 1
    Const iSubjectColumn         As Integer = 2
    Const iAppointmentTypeColumn As Integer = 3
    Dim dtStartDate              As Date
    Dim dtEndDate                As Date
    Dim dtThisDate               As Date
    Dim dtLoopDate               As Date
    Dim dtStartTime              As Date
    Dim sFilter                  As String
    Dim sDate                    As String
    Dim dtOriginalDate           As Date
    Dim dtNewDate                As Date
    Dim obOutlook                As Object
    Dim obNameSpace              As Object
    Dim obAppointments           As Object
    Dim obFilterAppointments     As Object
    Dim obAppointmentItem        As Object
    Dim obAppointmentItemExcept  As Object
    Dim obPattern                As Object
    Dim obPatternOccurrence      As Object
    Dim obExceptions             As Object
    Dim obException              As Object
    Dim bOutlookOpened           As Boolean
    Dim lRow                     As Long

    ThisWorkbook.Sheets("TEST").Range("A1:D100").ClearContents

    ' Initialize VBA.
    On Error Resume Next
    Set obOutlook = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Err.Clear
        Set obOutlook = CreateObject("Outlook.Application")
        bOutlookOpened = False
    Else
        bOutlookOpened = True
    End If
    On Error GoTo 0
    Set obNameSpace = obOutlook.GetNamespace("MAPI")
    Set obAppointments = obNameSpace.GetDefaultFolder(olFolderCalendar).Items

    ' Date range to search in.
    dtStartDate = #5/8/2021#
    dtEndDate = #5/9/2021#
    If dtEndDate < dtStartDate Then
        MsgBox "Your end date is before your start date, doofus."
        Exit Sub
    End If

    ' Construct filter on date range.
    sFilter = "[Start] >= """ & Format$(dtStartDate, "mm/dd/yyyy") & " 00:00 AM""" & _
    " AND [End] <= """ & Format$(dtEndDate, "mm/dd/yyyy") & " 11:59 PM"""

    ' Get Appointments in date range.
    obAppointments.IncludeRecurrences = True
    Set obFilterAppointments = obAppointments.Restrict(sFilter)

    ' Iterate through appointments, write to spreadsheet.
    ' Current row number.
    lRow = 1
    For Each obAppointmentItem In obFilterAppointments
        With obAppointmentItem
            ' Recurring appointment.
            If .IsRecurring Then
                Set obPattern = .GetRecurrencePattern
                ' Appointment time
                dtStartTime = obPattern.StartTime
                ' Loop over all dates in date range.
                For dtLoopDate = dtStartDate To dtEndDate
                    dtThisDate = dtLoopDate + dtStartTime
                    ' See if there's an appointment on this date at the original time.
                    On Error Resume Next
                    Set obPatternOccurrence = obPattern.GetOccurrence(dtThisDate)
                    On Error GoTo 0
                    If Not obPatternOccurrence Is Nothing Then
                        sDate = Format(obPatternOccurrence.Start, "yyyy/mm/dd hh:nn:ss")
                        ThisWorkbook.Sheets("TEST").Cells(lRow, iDateColumn).Value = sDate
                        ThisWorkbook.Sheets("TEST").Cells(lRow, iSubjectColumn).Value = .subject
                        ThisWorkbook.Sheets("TEST").Cells(lRow, iAppointmentTypeColumn).Value = "Recurring"
                        lRow = lRow + 1
                    End If
                    Set obPatternOccurrence = Nothing
                Next dtLoopDate

                Set obExceptions = obPattern.Exceptions
                For Each obException In obExceptions
                    If Not obException.Deleted Then
                        dtOriginalDate = obException.OriginalDate
                        'On Error Resume Next
                        ' ############# THIS IS THE PROBLEM LINE #############
                        Set obAppointmentItemExcept = obException.appointmentItem
                        'On Error GoTo 0
                        dtNewDate = obAppointmentItemExcept.Start

                        If dtOriginalDate <> dtNewDate And dtStartDate < dtNewDate And dtNewDate < dtEndDate Then
                            ThisWorkbook.Sheets("TEST").Cells(lRow, iDateColumn).Value = Format(dtNewDate, "yyyy/mm/dd hh:nn:ss")
                            ThisWorkbook.Sheets("TEST").Cells(lRow, iSubjectColumn).Value = obAppointmentItemExcept.subject
                            ThisWorkbook.Sheets("TEST").Cells(lRow, iAppointmentTypeColumn).Value = "Exception to Recurring"
                            lRow = lRow + 1
                        End If
                    End If
                Next

            ' One-time appointment.
            Else
                ThisWorkbook.Sheets("TEST").Cells(lRow, iDateColumn).Value = Format(.Start, "yyyy/mm/dd hh:nn:ss")
                ThisWorkbook.Sheets("TEST").Cells(lRow, iSubjectColumn).Value = .subject
                ThisWorkbook.Sheets("TEST").Cells(lRow, iAppointmentTypeColumn).Value = "One-time Appointment"
                lRow = lRow + 1
            End If

        End With
    Next

    If bOutlookOpened = False Then obOutlook.Quit
    MsgBox "DONE"
End Sub
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

DavidLambert

New Member
Joined
May 24, 2021
Messages
2
Office Version
  1. 2019
Platform
  1. Windows
Note: I chose late binding because I'd rather avoid having to instruct the people using this how to add a reference in Excel to an Outlook library.
 

Forum statistics

Threads
1,136,796
Messages
5,677,785
Members
419,720
Latest member
kurman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top