Outlook Calendar (VBA)

[Jing]

I have the below code that pulls the subject, start / end date, start / end time, location, and category from my outlook calendar. however i am trying to find a way to pull the organizer of the calendar event / meeting.

Any idea's?

Thank you in advance.

Dim bWeStartedOutlook As BooleanPrivate Function GetCalData(StartDate As Date, _
                Optional EndDate As Date) As Boolean
' Exports calendar information to Excel worksheet
' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much
' slower (~8 secs vs. 2 secs w/ Outlook open).
' End Date is optional, if you want to pull from
' only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------
 
Dim ThisAppt As Object ' Outlook.AppointmentItem
Dim MyItem As Object
Dim StringToCheck As String
Dim i As Long
 
' if no end date was specified, then the requestor
' only wants one day, so set EndDate = StartDate
' this will let us return appts from multiple dates,
' if the requestor does in fact set an appropriate end date
If EndDate = "12:00:00 AM" Then
  EndDate = StartDate
End If
 
If EndDate < StartDate Then
  MsgBox "Those dates seem switched, please check" & _
      "them and try again.", vbInformation
  GoTo ExitProc
End If
 
' get Outlook
Dim olApp As Object '  Outlook.Application
Set olApp = GetOutlookApp
If olApp Is Nothing Then
  MsgBox "Cannot start Outlook.", vbExclamation
  GoTo ExitProc
End If
 
' get default Calendar
Dim olNS As Object ' Outlook.Namespace
Dim myCalItems As Object ' Outlook.Items
Set olNS = olApp.GetNamespace("MAPI")
Set myCalItems = olNS.GetDefaultFolder(9).Items ' olFolderCalendar
 
' ------------------------------------------------------------------
' the following code adapted from:
' http://www.outlookcode.com/article.aspx?id=30
'
With myCalItems
  .Sort "[Start]", False
  .IncludeRecurrences = False
End With
'
StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & _
    " AND [End] <= " & Quote(EndDate & " 11:59 PM")
Debug.Print StringToCheck
'
Dim ItemstoCheck As Object ' Outlook.Items
Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
Debug.Print ItemstoCheck.Count
' ------------------------------------------------------------------
 
If ItemstoCheck.Count > 0 Then
  ' we found at least one appt
  ' check if there are actually any items in the collection,
  ' otherwise exit
  If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
 
  ' set up worksheet
  Dim MyBook As Excel.Workbook
  Dim xlSht As Excel.Worksheet
  Dim rngStart As Excel.Range
  Dim rngHeader As Excel.Range
 
  Set MyBook = Excel.Workbooks.Add
  Set xlSht = MyBook.Sheets(1)
  Set rngStart = xlSht.Range("A1")
  Set rngHeader = Range(rngStart, rngStart.Offset(0, 6))
 
  ' with assistance from Jon Peltier http://peltiertech.com/WordPress and
   ' http://support.microsoft.com/kb/306022
  rngHeader.Value = Array("Subject", "Start Date", "Start Time", "End Date", _
 "End Time", "Location", "Categories")
 
  ' create/fill array with exported info
  Dim ColCount As Long
  Dim arrData As Variant
  ColCount = rngHeader.Columns.Count
 
  ReDim arrData(1 To ItemstoCheck.Count, 1 To ColCount)
 
  For i = 1 To ItemstoCheck.Count
    Set ThisAppt = ItemstoCheck.Item(i)
 
    arrData(i, 1) = ThisAppt.Subject
    arrData(i, 2) = Format(ThisAppt.Start, "MM/DD/YYYY")
    arrData(i, 3) = Format(ThisAppt.Start, "HH:MM AM/PM")
    arrData(i, 4) = Format(ThisAppt.End, "MM/DD/YYYY")
    arrData(i, 5) = Format(ThisAppt.End, "HH:MM AM/PM")
    arrData(i, 6) = ThisAppt.Location
 
    If ThisAppt.Categories <> "" Then
      arrData(i, 7) = ThisAppt.Categories
    End If
  Next i
 
  rngStart.Offset(1, 0).Resize(ItemstoCheck.Count, ColCount).Value = arrData
 
Else
    MsgBox "There are no original appointments or meetings during" & _
      "the time you specified. Exiting now.", vbCritical
    GoTo ExitProc
End If
 
' if we got this far, assume success
GetCalData = True
 
ExitProc:
If bWeStartedOutlook Then
  olApp.Quit
End If
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing
End Function
Private Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
  Quote = Chr(34) & MyText & Chr(34)
End Function
Function GetOutlookApp() As Object
On Error Resume Next
  Set GetOutlookApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set GetOutlookApp = CreateObject("Outlook.Application")
    bWeStartedOutlook = True
  End If
On Error GoTo 0
End Function
Sub test()
  Dim success As Boolean
  success = GetCalData("1/1/2013", "12/30/2050")
End Sub

 

[Jing]

Never mind, i figured it out

 

[Jing]

Sorry for the confusion in bringing this thread back... i just didn't see it being necessary to re-create the post with the exact same code.

Anyway, my question is as follows.

is there a way to make this code pull all instances of an even / meeting where if the event in question is reoccurring it does not just pull the first instance of the event and no other future events?

 

[John_w]

is there a way to make this code pull all instances of an even / meeting where if the event in question is reoccurring it does not just pull the first instance of the event and no other future events?

You would use the IsRecurring property and GetRecurrencePattern. Example code here - http://technet.microsoft.com/en-us/library/ee692908.aspx

 

[Jing]

Pardon my ignorance as i am not very fluent with writing code. i just found the above online.

I have been trying to follow the URL you provided to see about modifying the code to have it collect the re-occurring calendar events but i can't get it to work at all.

would anyone be able to update the code if you would be so kind.

Thank you.

 

[Jing]

i have been attempting for figure this out by reading tutorials online and using the isrecurring and getrecurrencepattern commands that has been mentioned with no luck

could someone assist with this?

Thank you so much.

 

[John_w]

Try this.

Option Explicit

Dim bWeStartedOutlook As Boolean

Private Function GetCalData(StartDate As Date, Optional EndDate As Date) As Boolean
    ' Exports calendar information to Excel worksheet
    ' -------------------------------------------------
    ' Notes:
    ' If Outlook is not open, it still works, but much
    ' slower (~8 secs vs. 2 secs w/ Outlook open).
    ' End Date is optional, if you want to pull from
    ' only one day, use: Call GetCalData("7/14/2008")
    ' -------------------------------------------------
    
    Dim ThisAppt As Object ' Outlook.AppointmentItem
    Dim MyItem As Object
    Dim StringToCheck As String
    Dim i As Long
    
    ' if no end date was specified, then the requestor
    ' only wants one day, so set EndDate = StartDate
    ' this will let us return appts from multiple dates,
    ' if the requestor does in fact set an appropriate end date
    If EndDate = "12:00:00 AM" Then
        EndDate = StartDate
    End If
    
    If EndDate < StartDate Then
        MsgBox "Those dates seem switched, please check" & _
        "them and try again.", vbInformation
        GoTo ExitProc
    End If
    
    ' get Outlook
    Dim olApp As Object '  Outlook.Application
    Set olApp = GetOutlookApp
    If olApp Is Nothing Then
        MsgBox "Cannot start Outlook.", vbExclamation
        GoTo ExitProc
    End If
    
    ' get default Calendar
    Dim olNS As Object ' Outlook.Namespace
    Dim myCalItems As Object ' Outlook.Items
    Set olNS = olApp.GetNamespace("MAPI")
    Set myCalItems = olNS.GetDefaultFolder(9).Items ' olFolderCalendar
    
    ' ------------------------------------------------------------------
    ' the following code adapted from:
    ' http://www.outlookcode.com/article.aspx?id=30
    '
    With myCalItems
        .Sort "[Start]", False
        .IncludeRecurrences = True
    End With
    '
    StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & _
        " AND [End] <= " & Quote(EndDate & " 11:59 PM")
    Debug.Print StringToCheck
    '
    Dim ItemstoCheck As Object ' Outlook.Items
    Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
    Debug.Print ItemstoCheck.Count
    ' ------------------------------------------------------------------
    
    If ItemstoCheck.Count > 0 Then
        ' we found at least one appt
        ' check if there are actually any items in the collection,
        ' otherwise exit
        If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
        
        ' set up worksheet
        Dim MyBook As Excel.Workbook
        Dim xlSht As Excel.Worksheet
        Dim rngStart As Excel.Range
        Dim rngHeader As Excel.Range
    
        Set MyBook = Excel.Workbooks.Add
        Set xlSht = MyBook.Sheets(1)
        Set rngStart = xlSht.Range("A1")
        Set rngHeader = Range(rngStart, rngStart.Offset(0, 6))
        
        ' with assistance from Jon Peltier http://peltiertech.com/WordPress and
        ' http://support.microsoft.com/kb/306022
        rngHeader.Value = Array("Subject", "Start Date", "Start Time", "End Date", "End Time", "Location", "Categories")
    
        ' create/fill array with exported info
        'Dim ColCount As Long
        'Dim arrData As Variant
        'ColCount = rngHeader.Columns.Count
        'ReDim arrData(1 To ItemstoCheck.Count, 1 To ColCount)
        
        Dim r As Long
        Dim outRecurrencePattern As Object
        
        r = 0
        For Each ThisAppt In ItemstoCheck
            r = r + 1
            rngStart.Offset(r, 0).Value = ThisAppt.Subject
            rngStart.Offset(r, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
            rngStart.Offset(r, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
            rngStart.Offset(r, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
            rngStart.Offset(r, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
            rngStart.Offset(r, 5).Value = ThisAppt.Location
            rngStart.Offset(r, 6).Value = ThisAppt.Categories
        
            If ThisAppt.IsRecurring Then
                
                'Loop through recurring events for this appointment
                
                Set outRecurrencePattern = ThisAppt.GetRecurrencePattern
                Do
                    Set ThisAppt = GetNextOccurrence(ThisAppt.Start, EndDate, outRecurrencePattern)
                    If Not ThisAppt Is Nothing Then
                        r = r + 1
                        rngStart.Offset(r, 0).Value = ThisAppt.Subject
                        rngStart.Offset(r, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
                        rngStart.Offset(r, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
                        rngStart.Offset(r, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
                        rngStart.Offset(r, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
                        rngStart.Offset(r, 5).Value = ThisAppt.Location
                        rngStart.Offset(r, 6).Value = ThisAppt.Categories
                   End If
                Loop Until ThisAppt Is Nothing
            
            End If
        
            DoEvents
        Next
                
    Else
        MsgBox "There are no original appointments or meetings during" & _
            "the time you specified. Exiting now.", vbCritical
        GoTo ExitProc
    End If
    
    ' if we got this far, assume success
    GetCalData = True
    
ExitProc:
    If bWeStartedOutlook Then
olApp.Quit
    End If
    Set myCalItems = Nothing
    Set ItemstoCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Set rngStart = Nothing
    Set ThisAppt = Nothing
End Function

Private Function GetNextOccurrence(ByVal startDateTime As Date, EndDate As Date, outRP As Object) As Object 'Outlook.AppointmentItem

    'Increment startDateTime by 1 day until a valid calendar appointment is found or the date exceeds endDate
    
    Do
        startDateTime = startDateTime + 1
        Set GetNextOccurrence = Nothing
        On Error Resume Next
        Set GetNextOccurrence = outRP.GetOccurrence(startDateTime)
        On Error GoTo 0
    Loop While GetNextOccurrence Is Nothing And Int(startDateTime) <= Int(EndDate)
    If Int(startDateTime) > Int(EndDate) Then Set GetNextOccurrence = Nothing
    
End Function

Private Function Quote(MyText)
    ' from Sue Mosher's excellent book "Microsoft Outlook Programming"
    Quote = Chr(34) & MyText & Chr(34)
End Function

Function GetOutlookApp() As Object
    On Error Resume Next
    Set GetOutlookApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set GetOutlookApp = CreateObject("Outlook.Application")
        bWeStartedOutlook = True
    End If
    On Error GoTo 0
End Function

Sub test()
    Dim success As Boolean
    success = GetCalData("1/1/2013", "12/30/2050")
End Sub

 

[Jing]

You are a genius.
This does take some time to run but that's OK... i start it at the end of my shift. When i come back the next day and i am good to go

I thank you so much.

 

[John_w]

There are 2 reasons for the slowness:

1. The test routine as posted gets appointment dates up to the year 2050. If you only want dates for the next year change it to:

Sub test()     
   Dim success As Boolean     
   success = GetCalData(Date, Date + 365) 
End Sub

2. The GetNextOccurrence function looks for the next date for a recurring appointment by incrementing the start date by 1 day at a time. This has the advantage of simplicity, but needs to be cleverer if you want it to be faster. For example, if the RecurrencePattern for an appointment date says it recurs weekly on one day a week (DayOfWeekMask matches 1 day only) then the code could increment the start date by 7 days, allowing it to scan much faster through the dates until the end date.