Extract Calendar data from Outlook into Excel

I completed some VBA code that will allow you to export appointment information (meetings, appointments) from Outlook into Excel. It requires a reference to the Outlook object library (unless you care to reengineer it), but it works even with Outlook closed. I think you'll find it very useful for when you need to examine or manipulate Outlook Calendar data, and want something a bit faster (and more flexible) than Outlook's built-in exporter.

The code begins by setting a reference to the Outlook Application object, which, depending on whether Outlook is open or not, can take up to 10 seconds, so I strongly recommend you have Outlook open when you run this code. Then we reference the default Calendar folder and filter out the items based on dates passed as arguments to the sub.

Because recurring appointments can potentially have an unlimited number of recurrences (when the organizer does not specify an End Date), we use the Restrict method to limit the number of calendar entries we need to return to only those that fall between 12 AM on the start date and 11:59 PM on the end date.

Be careful with the Restrict method, however; if you use it in an Exchange environment, it can slow down Outlook's performance.

Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)

' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
' Make sure to reference the Outlook object library before running the code
' End Date is optional, if you want to pull from only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim myCalItems As Outlook.Items
Dim ItemstoCheck As Outlook.Items
Dim ThisAppt As Outlook.AppointmentItem

Dim MyItem As Object

Dim StringToCheck As String

Dim MyBook As Excel.Workbook
Dim rngStart As Excel.Range

Dim i As Long
Dim NextRow 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

If EndDate - StartDate > 28 Then
  ' ask if the requestor wants so much info
  If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
      GoTo ExitProc
  End If
End If

' get or create Outlook object and make sure it exists before continuing
On Error Resume Next
  Set olApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set olApp = CreateObject("Outlook.Application")
  End If
On Error GoTo 0
If olApp Is Nothing Then
  MsgBox "Cannot start Outlook.", vbExclamation
  GoTo ExitProc
End If

Set olNS = olApp.GetNamespace("MAPI")
Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items

' ------------------------------------------------------------------
' 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
'
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 MyBook = Excel.Workbooks.Add
  Set rngStart = MyBook.Sheets(1).Range("A1")

  With rngStart
    .Offset(0, 0).Value = "Subject"
    .Offset(0, 1).Value = "Start Date"
    .Offset(0, 2).Value = "Start Time"
    .Offset(0, 3).Value = "End Date"
    .Offset(0, 4).Value = "End Time"
    .Offset(0, 5).Value = "Location"
    .Offset(0, 6).Value = "Categories"
  End With

  For Each MyItem In ItemstoCheck
    If MyItem.Class = olAppointment Then
    ' MyItem is the appointment or meeting item we want,
    ' set obj reference to it
      Set ThisAppt = MyItem
      NextRow = WorksheetFunction.CountA(Range("A:A"))

      With rngStart
        .End(xlDown).End(xlUp).Offset(NextRow, 0).Value = ThisAppt.Subject
        .End(xlDown).End(xlUp).Offset(NextRow, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
        .End(xlDown).End(xlUp).Offset(NextRow, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
        .End(xlDown).End(xlUp).Offset(NextRow, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
        .End(xlDown).End(xlUp).Offset(NextRow, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
        .End(xlDown).End(xlUp).Offset(NextRow, 5).Value = ThisAppt.Location

        If ThisAppt.Categories <> "" Then
          .End(xlDown).End(xlUp).Offset(NextRow, 6).Value = ThisAppt.Categories
        Else
          .End(xlDown).End(xlUp).Offset(NextRow, 6).Value = "n/a"
        End If
      End With
    End If
  Next MyItem

  ' make it pretty
  Call Cool_Colors(rngStart)

Else
    MsgBox "There are no appointments or meetings during" & _
      "the time you specified. Exiting now.", vbCritical
End If

ExitProc:
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing
End Sub
Private Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
  Quote = Chr(34) & MyText & Chr(34)
End Function
Private Sub Cool_Colors(rng As Excel.Range)
'
' Lt Blue BG with white letters
'
'
With Range(rng, rng.End(xlToRight))
  .Font.ColorIndex = 2
  .Font.Bold = True
  .HorizontalAlignment = xlCenter
  .MergeCells = False
  .AutoFilter
  .CurrentRegion.Columns.AutoFit
  With .Interior
    .ColorIndex = 41
    .Pattern = xlSolid
  End With
End With

End Sub

Let's examine exactly what is going on here.

Our sub accepts two arguments, the start date and end date. The end date is optional, in case we only want to check one day. If the end date is "12:00:00 AM", this means no end date was specified, therefore we can set the end date = start date.

If the end date is later than the start date, the user might have made an error; we can simply exit and allow them to rerun the sub.

After hooking the Outlook application and setting a reference to the default Calendar, we build a string used to restrict the Calendar items returned to only those that start or end within the date range arguments passed to the sub. The Restrict method has a funny way of requiring quotation marks, so using the Quote UDF from Sue Mosher's book Microsoft Outlook Programming ensures that our quotation marks will be formatted properly for the Restrict method.

Then it's a simple matter of copying the information from each appointment to a new workbook. Notice that I hand selected certain properties to export; you can export whatever properties you want (see Outlook 2003 VBA Reference). All you need to do is update the two "With rngStart" sections.

I exported the date and time as two separate fields, if you wanted to combine them it would be something like:

Format(ThisAppt.Start, "MM/DD/YYYY HH:MM AM/PM")
Format(ThisAppt.End, "MM/DD/YYYY HH:MM AM/PM")

To export your Calendar items, just call the main sub like this:

Sub GetApptsFromOutlook()
Application.ScreenUpdating = False
  Call GetCalData("7/20/2008", "8/6/2008")
Application.ScreenUpdating = True
End Sub

In the spirit of modularization, I broke out the code that pretties up the header row into its own sub; we just pass the header row as a Range object.

One minor issue we have to deal with is if there are no appointments, the code runs all the way to the For loop (after we have already populated the header row of the new worksheet) and then exits. This is because ItemstoCheck.Count returns 2147483647 (not 0), even if the date range we specified contains no appointments (based on my experiments). So if we pick a date range with no appointments, we'll end up with a useless blank spreadsheet with a populated header row.

The way we solve this problem is to add a line that checks to see if there are any actual objects found by the Restrict method, and exits if there's really nothing there. This line does just that.

If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc

Here is a sample of the finished product.

Export Calendar Data Screenshot

Enjoy,
JP

About JP

I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space to learn more about VBA. Keep Reading »



Share This Article:

Share and bookmark this articledelicious buttonfacebook buttonlinkedin buttonstumbleupon buttontwitter button

comment bubble 96 Comment(s) on Extract Calendar data from Outlook into Excel:

  1. What can be done to pass variables to the Start and End Dates so that we don't have to update the Sub each and every time we want to change the dates?

    I'm pretty novice at this stuff. I've tried passing variables via a Range with the date and input boxes

  2. Hey Ryan,

    The sub is designed so you can change the start and end dates as needed.

    Sub GetApptsFromOutlook()
    Application.ScreenUpdating = False
      Call GetCalData("7/20/2008", "8/6/2008")
    Application.ScreenUpdating = True
    End Sub

    Just change the two arguments (dates) as needed.

    If you wanted to hard code the start and end dates, just change the first line of the sub to:

    Private Sub GetCalData()

    And you would have to add

    Const StartDate As Date = #7/20/2008#
    Const EndDate As Date = #8/6/2008#

    right below that.

    HTH,
    JP

  3. First, I want to say thanks for making this available. I was able to get it to pull from my default calendar in about 10 minutes.

    How can I pull events from a public calendar?

    Thanks,

    Mary

  4. Hi Mary,

    You can try to change line 57 to point to the public folder, but more likely you'll need to use CDO.

    Although I did find a function here that might do what you want: http://www.outlookcode.com/codedetail.aspx?id=1164

    –JP

  5. Paul Moser writes:

    Excellent!

  6. David Collins writes:

    Brilliant code, however i would also like to be able to include items which have been recently updated? I have (in a cell) the last update time of the sheet, and in a seperate sheet i want to show items which have been put into the calendar after that input time.

    UpdateDate = Worksheets("Staff").Range("Updated_Date").Text
    
        StringToCheck = "[LastModificationTime] = " & Quote(StartDate & " 12:00 AM") & " AND [Start] <= " & _
        Quote(EndDate & " 11:59 PM")
    
    Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
    
    

    The format of the text in the update cell is 15/12/2008 09:23:05 (note 2 spaces in between date and time, that seems to be how outlook handles it).

    Simply, it isnt working, and isnt showing up any updates which fall within the specified range (this is vital).

    Many thanks

  7. Try modifying the StringToCheck line as follows:

    StringToCheck = "[LastModificationTime]>= " & Quote(StartDate & " 12:00 AM") & " AND [LastModificationTime] <= " & Quote(EndDate & " 11:59 PM")

    Then call it the usual way:

    Sub GetApptsFromOutlook()
    Application.ScreenUpdating = False
      Call GetCalData("7/20/2008", "8/6/2008")
    Application.ScreenUpdating = True
    End Sub

    This should pick up any appointments that have been updated during that time frame.

  8. David Collins writes:

    Thanks JP, I tested that but it didnt work. In the meanwhile I have found another way of doing it.

    in the portion which starts;

    With rngStart
    .end(xldown).end(xlup).offset(nextrow, 0).value = ThisAppt.Subject
    

    I have added a portion just after With rngStart which checks ThisAppt.CreationTime > UpdateDate and then inserts those items into my sheet. It will only do this if i call it from another button where i have a boolean value set to true. If the value is set to False, it will run through all of the items, ignoring the creationtime criteria set.

  9. Your comparison will only pull appointments that were created after a date you specify. It doesn't actually check if the appointments are actually updated. That would defeat the purpose of having a sub where you specify the start and end dates as arguments. For example, you're calling the sub with the start date of 10/1/2008 and end date of 10/2/2008, then inside the sub you are changing the start date.

    ps- it looks like you are using European dates? Just checking.

    The CreationTime represents the date/time the appointment was created. If you update it later, the CreationTime wouldn't change. You need to compare the LastModificationTime with the CreationTime and only import those where the two are different (and where LastModificationTime <> 1/1/4501). Or am I misunderstanding what you're doing?

    If it does what you want, that's all that matters, but I'm not understanding how it's working.

    [I forgot to mention that if LastModificationTime equals 1/1/4501, that means the appointment has never been updated. --JP]

  10. David Collins writes:

    Basically, I have 2 sheets, each with a button on. First sheet fills with all of the appointments within the specified range. The second sheet is used for daily checking for new appointments so our office wall board can be updated much more easily.

    As ongoing development i will be investigating using the LastModificationTime as well/instead of the CreationTime, but as it stands it seems to work quite well for our needs.

    Many thanks for your suggestion as it sent me in the right direction of the solution.

  11. Hello JP,

    Thank you for your VBA codes. I'm a newbie with VBA. I run the script and got a compile error: "User-defined type not defined" on line 10 – Dim olApp As Outlook.Application

    I have Outlook running. What am I missing?

    Thanks,
    –Tony

    • Tony,
      You have to set a reference to the Outlook object library. Go to Tools » References and find "Microsoft Outlook Object 11.0 Library" and select it. When you run the code again, it should work.

  12. JP,

    Thanks for the code!

    Is there a way to pull this from a shared calendar instead of just mine?

    Thanks,

    James

  13. James,

    You'll need to change

    Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items

    to point to the Calendar you want to extract from. For example if the name of the shared mailbox is "My Department", the line would be

    Set myCalItems = olNS.Folders("Mailbox – My Department").Folders("Calendar").Items

    HTH

  14. My mistake, you probably want to use a technique like this to get a MAPIFolder object reference to a specific folder.

    GetFolder

  15. Mary Haskell writes:

    JP
    I tried to access the shared calendar for another user Example
    Set myCalItems = olNS.Folders("Mailbox – My Department").Folders("Calendar").Items
    But this did not appear to work.

    I receive an Run time error. It says an object can not be found. I tested that I can access the users calendar through outlook. Any ideas?
    Thank you,
    Mary

  16. Mary,

    You'll need to use the GetFolder Method to set a reference to the public calendar. The code here can get you started:

    GetFolder Method

  17. Mary Haskell writes:

    Here is the code to access a public folder..
    You need to change
    Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items

    to
    Set myCalItems = olNS.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Some Folder Name").Items

    Change the "some folder name" to your calendar name.

    Thanks,
    Mary

  18. Great job Mary! Thanks for commenting.

  19. Mary Haskell writes:

    I'm using the code to extract my calendar items as per the first three code listings. I have a need to "parse" my categories creating two columns. Any suggestions on how to do this?

    Or can you direct me to someone who can help.

    Thank you!

  20. Mary Haskell writes:

    I have figured out the parsing with some help from Experts-exchange.

    I have one more "Challenge" to overcome….
    I do not want to pull any appointment that have a 24 hour duration or is listed as a AlldayAppointment.

    Can you Help?

    Thank you!

     Sub GetCMCTIMESheet(StartDate As Date, Optional EndDate As Date)
    
    ' -------------------------------------------------
    ' Notes:
    ' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
    ' Make sure to reference the Outlook object library before running the code
    ' End Date is optional, if you want to pull from only one day, use: Call GetCMCTIMESheet("7/14/2008")
    ' -------------------------------------------------
    
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim myCalItems As Outlook.Items
    Dim ItemstoCheck As Outlook.Items
    Dim ThisAppt As Outlook.AppointmentItem
    
    Dim MyItem As Object
    
    Dim StringToCheck As String
    
    Dim MyBook As Excel.Workbook
    Dim rngStart As Excel.Range
    
    Dim i As Long
    Dim NextRow 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  28 Then
      ' ask if the requestor wants so much info
      If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
          GoTo ExitProc
      End If
    End If
    
    ' get or create Outlook object and make sure it exists before continuing
    On Error Resume Next
      Set olApp = GetObject(, "Outlook.Application")
      If Err.Number  0 Then
        Set olApp = CreateObject("Outlook.Application")
      End If
    On Error GoTo 0
    If olApp Is Nothing Then
      MsgBox "Cannot start Outlook.", vbExclamation
      GoTo ExitProc
    End If
    
    Set olNS = olApp.GetNamespace("MAPI")
    Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Folders("CMC - TimeSheet").Items
    
    ' ------------------------------------------------------------------
    ' 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]  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 MyBook = Excel.Workbooks.Add
      Set rngStart = MyBook.Sheets(1).Range("A1")
    
      With rngStart
        .Offset(0, 0).Value = "Transaction Date"
        .Offset(0, 1).Value = "Customer"
        .Offset(0, 2).Value = "Service Item"
        .Offset(0, 3).Value = "Duration"
        .Offset(0, 4).Value = "Billiable"
        .Offset(0, 5).Value = "Notes"
    
      End With
    
      For Each MyItem In ItemstoCheck
        If MyItem.Class = olAppointment Then
        ' MyItem is the appointment or meeting item we want,
        ' set obj reference to it
          Set ThisAppt = MyItem
          NextRow = WorksheetFunction.CountA(Range("A:A"))
    
           With rngStart
            .End(xlDown).End(xlUp).Offset(NextRow, 0).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
            .End(xlDown).End(xlUp).Offset(NextRow, 1).Value = ThisAppt.Subject
    
            If ThisAppt.Categories = "" Then
              .End(xlDown).End(xlUp).Offset(NextRow, 2).Value = "n/a"
            Else
            .End(xlDown).End(xlUp).Offset(NextRow, 2).Value = IIf(InStr(1, ThisAppt.Categories, ",") > 0, _
                Trim(Split(ThisAppt.Categories, ",")(1)), "") 'second category if applicable
                    End If
    
            .End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.Duration / 60
    
            .End(xlDown).End(xlUp).Offset(NextRow, 4).Value = IIf(InStr(1, ThisAppt.Categories, ",") > 0, _
                Trim(Split(ThisAppt.Categories, ",")(1)), "") 'second category if applicable
    
    
            If ThisAppt.Categories Like "Billable-yes*" Then
              .End(xlDown).End(xlUp).Offset(NextRow, 4).Value = "Y"
            ElseIf ThisAppt.Categories Like "Billable-No*" Then
              .End(xlDown).End(xlUp).Offset(NextRow, 4).Value = "N"
            ElseIf ThisAppt.Categories  "" Then
              .End(xlDown).End(xlUp).Offset(NextRow, 4).Value = "n/a"
    
            End If
            .End(xlDown).End(xlUp).Offset(NextRow, 5).Value = (Format(ThisAppt.Start, "MM/DD/YYYY")) + " - " + ThisAppt.Body
    
    
            End With
        End If
      Next MyItem
    
      ' make it pretty
      Call Cool_Colors(rngStart)
    
    Else
        MsgBox "There are no appointments or meetings during" & _
          "the time you specified. Exiting now.", vbCritical
    End If
    
    ExitProc:
    Set myCalItems = Nothing
    Set ItemstoCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Set rngStart = Nothing
    Set ThisAppt = Nothing
    End Sub
    
    Private Function Quote(MyText)
    ' from Sue Mosher's excellent book "Microsoft Outlook Programming"
      Quote = Chr(34) & MyText & Chr(34)
    End Function
    
    Private Sub Cool_Colors(rng As Excel.Range)
    '
    ' Lt Blue BG with white letters
    '
    '
    With Range(rng, rng.End(xlToRight))
      .Font.ColorIndex = 2
      .Font.Bold = True
      .HorizontalAlignment = xlCenter
      .MergeCells = False
      .AutoFilter
      .CurrentRegion.Columns.AutoFit
      With .Interior
        .ColorIndex = 41
        .Pattern = xlSolid
      End With
    End With
    
    End Sub
    • Mary,

      Right after

      Set ThisAppt = MyItem

      Add in this line:

      If (ThisAppt.Duration = 1440) Or (ThisAppt.AllDayEvent = True) Then

      And right before the closing End If, add another End If.

      HTH

  21. This worked perfect!
    Thanks for your help…

    This code has allow us to pull tracked time from public calendars to a excel file that is in perfect format to import into quickbooks.

    This will allow our administrative asst. to save approx. 19 hours a month.

  22. I was wondering if you can tell me if there is a way to have a window pop up an prompt the user to enter a date instead of going into the macro and changing it. I'm assuming I would need to use sometype of variable. I was also thinking it would be cool if you could pull more than one calendar at time..I'm going to work on that in my free time.

    If you can even direct me on the window prompting I would certainly appreciate it.
    I have ordered a VB book that I'm hoping will help me. Thank you for all you have done. Your code has helped me greatly.

    • Check out the InputBox function. The end user would enter the start and end dates, then you call the function and pass that information as parameters. This sample code doesn't include any error handling, but should get you started.

      Dim dteStart As Date
      Dim dteEnd As Date
      
      dteStart = InputBox("What is the start date?")
      dteEnd = InputBox("What is the end date?")
      Call GetCalData(dteStart, dteEnd)

      As far as pulling from multiple calendars, that would be more difficult. The default Calendar is easy, because everyone has it, and GetDefaultFolder always finds it. But everyone has different (public) calendars, and some don't have any at all. How would you specify which calendar to export from?

  23. David Collins writes:

    I have managed to do the above requested by using the following. Please excuse my code as its rather cribbed together.

    Firstly, my workbook has 3 sheets, Weekly, Updated and Staff. A cell on weekly has a range name of From_Date, and another To_Date. Another cell on Updated has a range name of from_date_updated.

    My staff sheet has a list of names contained on it working downwards in column A. This is a list of calendar names (staff names in my case).

    Weekly has a button called bt_1. Updated has a button called bt_recent.

    Dim NextRow As Long
    
    Sub bt_1()
    
    Dim xrows As Integer
    Dim txtout As String
    Dim from As Date
    Dim todate As Date
    Dim SheetNameVar As String
    Dim ChkUpdateVar As Boolean
    
    SheetNameVar = ("Weekly")
    
    ChkUpdateVar = False
    
    from = Worksheets(SheetNameVar).Range("from_date").Value
    todate = Worksheets(SheetNameVar).Range("to_date").Value
    
    Worksheets(SheetNameVar).Range("A3:H1000").Clear
    
    xrows = 1
    Do Until Worksheets("Staff").Cells(xrows, 1).Value = ""
       txtout = Worksheets("Staff").Cells(xrows, 1)
        xrows = xrows + 1
    
    Application.ScreenUpdating = False
        Call GetCalData(from, txtout, SheetNameVar, ChkUpdateVar, todate)
    Application.ScreenUpdating = True
    
    Loop
    
    End Sub
    
    Sub bt_recent()
    
    Dim xrows As Integer
    Dim txtout As String
    Dim fromupdate As Date
    Dim todateupdate As Date
    Dim SheetNameVar As String
    Dim ChkUpdateVar As Boolean
    
    SheetNameVar = ("Updated")
    
    ChkUpdateVar = True
    
    fromupdate = Worksheets("Weekly").Range("from_date").Value
    todateupdate = Worksheets("Weekly").Range("to_date").Value
    
    Worksheets(SheetNameVar).Range("A3:H1000").Clear
    
    xrows = 1
    Do Until Worksheets("Staff").Cells(xrows, 1).Value = ""
       txtout = Worksheets("Staff").Cells(xrows, 1)
        xrows = xrows + 1
    
    Application.ScreenUpdating = False
        Call GetCalData(fromupdate, txtout, SheetNameVar, ChkUpdateVar, todateupdate)
    Application.ScreenUpdating = True
    
    Loop
    
    End Sub
    
    Public Function GetCalData(StartDate As Date, StaffName As String, SheetName As String, ChkUpdateFlag As Boolean, Optional EndDate As Date)
    
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim myCalItems As Outlook.Items
    Dim ItemstoCheck As Outlook.Items
    Dim ThisAppt As Outlook.AppointmentItem
    Dim MyItem As Object
    Dim StringToCheck As String
    Dim MyName As Outlook.Recipient
    Dim CalendarFolder As Outlook.Folder
    Dim MyBook As Excel.Workbook
    Dim rngStart As Excel.Range
    Dim i As Long
    Dim UpdateDate As Date
    
    UpdateDate = Worksheets("Updated").Range("from_date_update").Value
    
    If EndDate = "12:00:00 AM" Then
        EndDate = StartDate
    End If
    
    If EndDate  28 Then
        If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
            GoTo ExitProc
        End If
    End If
    
    On Error Resume Next
    
    Set olApp = GetObject(, "Outlook.Application")
        If Err.Number  0 Then
            Set olApp = CreateObject("Outlook.Application")
        End If
    
    On Error GoTo 0
    
    If olApp Is Nothing Then
        MsgBox "Cannot start Outlook.", vbExclamation
        GoTo ExitProc
    End If
    
    Set olNS = olApp.GetNamespace("MAPI")
    Set MyName = olNS.CreateRecipient(StaffName)
    
    MyName.Resolve
    
    On Error Resume Next
    
    Set myCalItems = olNS.GetSharedDefaultFolder(MyName, olFolderCalendar).Items
    
        With myCalItems
            .Sort "[Start]", False
            .IncludeRecurrences = True
        End With
    
            StringToCheck = "[End]>= " & Quote(StartDate & " 12:00 AM") & " AND [Start]  0 Then
    
        If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
    
            Set rngStart = Worksheets(SheetName).Range("A3")
    
                With rngStart
    
                    .Offset(0, 0).Value = "Name"
                    .Offset(0, 1).Value = "Subject"
                    .Offset(0, 2).Value = "Location"
                    .Offset(0, 3).Value = "Start Date"
                    .Offset(0, 4).Value = "Start Time"
                    .Offset(0, 5).Value = "End Date"
                    .Offset(0, 6).Value = "End Time"
    
                    If ChkUpdateFlag = False Then
                        '.Offset(0, 7).Value = "Category"
                    Else
                        .Offset(0, 7).Value = "Creation Date"
                    End If
    
                 End With
    
            For Each MyItem In ItemstoCheck
    
                If MyItem.Class = olAppointment Then
    
                    Set ThisAppt = MyItem
    
                        NextRow = WorksheetFunction.CountA(Range("A:A"))
    
                    With rngStart
    
                        If ChkUpdateFlag = True Then
    
                            If ThisAppt.CreationTime > UpdateDate Then
                                .End(xlDown).End(xlUp).Offset(NextRow, 0).Value = MyName
                                .End(xlDown).End(xlUp).Offset(NextRow, 1).Value = ThisAppt.Subject
                                .End(xlDown).End(xlUp).Offset(NextRow, 2).Value = ThisAppt.Location
                                .End(xlDown).End(xlUp).Offset(NextRow, 3).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
                                .End(xlDown).End(xlUp).Offset(NextRow, 4).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
                                .End(xlDown).End(xlUp).Offset(NextRow, 5).Value = Format(ThisAppt.End, "MM/DD/YYYY")
                                .End(xlDown).End(xlUp).Offset(NextRow, 6).Value = Format(ThisAppt.End, "HH:MM AM/PM")
                                .End(xlDown).End(xlUp).Offset(NextRow, 7).Value = ThisAppt.CreationTime
                            End If
    
                        Else
                            .End(xlDown).End(xlUp).Offset(NextRow, 0).Value = MyName
                            .End(xlDown).End(xlUp).Offset(NextRow, 1).Value = ThisAppt.Subject
                            .End(xlDown).End(xlUp).Offset(NextRow, 2).Value = ThisAppt.Location
                            .End(xlDown).End(xlUp).Offset(NextRow, 3).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
                            .End(xlDown).End(xlUp).Offset(NextRow, 4).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
                            .End(xlDown).End(xlUp).Offset(NextRow, 5).Value = Format(ThisAppt.End, "MM/DD/YYYY")
                            .End(xlDown).End(xlUp).Offset(NextRow, 6).Value = Format(ThisAppt.End, "HH:MM AM/PM")
                            '.End(xlDown).End(xlUp).Offset(NextRow, 7).Value = ThisAppt.Categories
                        End If
    
    
    
    
    
                    End With
    
                End If
    
            Next MyItem
    
      Call Cool_Colors(rngStart)
    
    Else
    
        MsgBox "There are no appointments or meetings during the time you specified. Exiting now.", vbCritical
    
    End If
    
    ExitProc:
    
    Set myCalItems = Nothing
    Set ItemstoCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Set rngStart = Nothing
    Set ThisAppt = Nothing
    
    End Function
    
    Private Function Quote(MyText)
      Quote = Chr(34) & MyText & Chr(34)
    End Function
    
    Private Sub Cool_Colors(rng As Excel.Range)
    '
    ' Lt Blue BG with white letters
    '
    '
    With Range(rng, rng.End(xlToRight))
      '.Font.ColorIndex = 2
      .Font.Bold = True
      .HorizontalAlignment = xlCenter
      .MergeCells = False
      .AutoFilter
      .CurrentRegion.Columns.AutoFit
      'With .Interior
      '  .ColorIndex = 41
      '  .Pattern = xlSolid
      'End With
    End With
    End Sub
  24. Mary Haskell writes:

    JP,
    The input code worked GREAT! Your are awesome…So I would use this.. with the "some Folders name" changing per user. I would also need to put this "somefoldername" in the excel spreadsheet so we know whos are whos. So I would add a column and call it user.
    As far as the calendars they are public

     Set myCalItems = olNS.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Some Folder Name").Items
  25. David — great job!

    Mary — check out David's code above. He added another argument to the function to change the Calendar to be searched. Then you just pass in the name of the public Calendar you want to search.

  26. Mary Haskell writes:

    How can I add a save file as to the orginal code. I would like for the user to run the macro and then it auto save the file with todays date or "text" that I specify.
    Thank you,

  27. Mary -

    After

    Call Cool_Colors(rngStart)

    put something like this:

    Dim dte As Date
    dte = Format(Now, "MMDDYYYY")
    ActiveWorkbook.SaveAs FileName:=dte

    If you wanted to specify text, you could either hard code it into the macro, or you'd need to add an additional argument to the macro (like in David's code above) and then use that for the filename. For example, change the first line of the macro to

    Private Sub GetCalData(StartDate As Date, Optional EndDate As Date, Optional strText As String)

    Then call the macro like this:

    GetCalData("11/1/2008", "11/10/2008","Friend")

    Then use the variable "strText" where you want it — in the filename…

    ActiveWorkbook.SaveAs FileName:=strText
  28. Hi all.

    I am very new to VBA but I wanted to try this code out. I actually type out a meeting schedule everyday and I thought this might help expedite the process. I don't know how to execute this code in the Excel workbook. Can anyone give me a little push to get me started?

    Thank you,
    Nathan

  29. Nathan,

    Here are some instructions that should help you. If not, contact me privately and I can send you the relevant code sections.

    1) Start Microsoft Excel.
    2) Press Alt-F11 to access the VB Editor.
    3) Create a new standard module, copy the above code sections into it (see http://www.rondebruin.nl/code.htm assistance with where to place the code). You just click "view plain" above each code section, then cut and paste the resulting code.
    4) Copy and paste the "GetApptsFromOutlook" code above, and edit it so it pulls from the appropriate date range.
    5) Click anywhere inside the "GetApptsFromOutlook" code and press F5 to run the code.

  30. Thanks JP. I got it to execute in the workbook but I get compile error here:

    StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & " AND [End] <= " & _
       Quote(EndDate & " 11:59 PM")
     Debug.Print StringToCheck 

    It tells me the "Quote()" function is not defined.

    Any idea why that is?

    Thanks,
    Nathan

  31. Make sure you copy the Quote function into the module as well. It's listed above but here it is again.

    Private Function Quote(MyText)
    ' from Sue Mosher's excellent book "Microsoft Outlook Programming"
      Quote = Chr(34) & MyText & Chr(34)
    End Function
  32. Thank you very much that did work.

  33. Glad to hear it Nathan.

  34. JP,

    Let me ask you a question. Would it be possible to access a calendar in another account on an exchange server if you had the username and password for the account?

    We have a situation where that occurs because of having meeting rooms set up with their own inbox for meeting requests.

    Sounds like a long shot but I thought I would ask.

    Thanks again,
    Nathan

  35. Do you mean a shared calendar, or a completely different user's calendar? If the latter, you'd need to have access to it, I think it's more than a matter of having the username and password. Since it's a calendar, you can add the profile to your account and access the calendars that way. See http://www.jpsoftwaretech.com/blog/2009/01/handling-multiple-inboxes/ for more information.

    Mary actually commented above with the necessary code:

    You need to change

    Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items

    to

    Set myCalItems = olNS.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Some Folder Name").Items

    Change the "some folder name" to your calendar name.

  36. Great code but im tryin to make it work on an existing excel worksheet with a command button at the top of the sheet. The code seems to open a brand new excel sheet when the command button is pressed when calling the code.

    How would i modify:

    Set MyBook = Excel.Workbooks.Add
    Set rngStart = MyBook.Sheets(1).Range("A1")

    to work on an existing defined range already defined in excel so i dont need to define it in the code over again.

    For example A2:F2 is already set to rngStart. A1 has commandbutton "View Appointments"

    • The problem is, you would have to know how many appointments Outlook is going to return. What happens if your range has three rows, but you have ten appointments? The results are unpredictable.

      If you did have a pre-existing workbook set up already, with a named range where you want the results to go, you need to rewrite the code to open that workbook instead, and write the results there. For example,

      Set MyBook = Excel.Workbooks.Open("C:\My_Existing_Workbook.xls")
      Set rngStart = MyBook.Sheets(1).Range("A2") 

      If you wanted the results to start in cell A2.

      HTH

  37. John Hutchinson writes:

    Hi

    Thank you for a very useful piece of code, being an Ada programmer I never realised VBA could read between outlook applications.

    However I am stuck. I have the same problem as Tony on 22 Dec:
    Thank you for your VBA codes. I'm a newbie with VBA. I run the script and got a compile error: "User-defined type not defined" on line 10 – Dim olApp As Outlook.Application.

    I am running Office 2007 and Excel References Microsoft Object Library 12.0. Is that the problem? I have installed the Outlook PIA lbraries with no success. Is it posible to reference the 11.0 library?

    Cheers
    John

    • John,
      Change the 'As Outlook' references to 'As Object' and it should work. Looking at the code again, it's a bit inefficient so I'll put it on my list of code to rewrite. I'll try to post the updated code within the week.

      Thanks!

  38. John Hutchinson writes:

    Hi JP

    Thank worked. I had to add the line
    Const olFolderCalendar = 9

    Kind Regards

    John

  39. LR_HD writes:

    Hi David,

    Could you please post your excel file? There are some characters missing in your code.

    Thanks!

  40. Jon Herries writes:

    Hi,

    I tried to get this up and running with a public folder on our exchange server. I finally got this to compile:

     Set myCalItems = olNS.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("CCR").Items 

    But it won't return any of the appointments in the "Community Teams" Calendar which sits in the CCR folder. The script tells me there are no appointments.

    The actual folder path is this:

    Public Folders\All Public Folders\CCR\Community Teams

    "Community Teams" is the calendar.

    But if I write it like this:

     Set myCalItems = olNS.GetDefaultFolder(olPublicFoldersAllPublicFoldersCCR).Folders("Community Teams").Items 

    It says the folder is empty (CCR), and has a compiler error.

    I can see the appointments in the calendar, any suggestions?

    • Try this:

      Set myCalItems = olNS.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("CCR").Folders("Community Teams").Items
  41. Brigette writes:

    Hi JP,

    This is awesome code – I've been looking around on the net for something usable all day!

    I'm pretty new to VBA, and am having some trouble with the following line:
    Set myCalItems = olNS.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Some Folder Name").Items

    I have one calendar especially (my boss's – a shared calendar) that I need to export, but I can't seem to get it to work …

    Do you have any tips?

    Thanks
    Brigette

    • Brigette,

      See my response to Jon above, you need to walk the folder hierarchy to get to the folder you need.

  42. Jon Herries writes:

    Hi JP,

    Worked brilliantly! Thanks for your help,

    Jon

  43. Hello JP, your code works great. I re-wrote it so its more visual on a VB form rather than looking on an plain Excel sheet, i removed the reference that it exports to a new Excel sheet but works all in one Excel file, the VB form gives it a professinal look.

    All i did was, create a VB form with a listbox, renamed a blank sheet called "Appointments", set a range in cell A2 to show required data in listbox1 with: ActiveWorkbook.Names.Add Name:="Apps", _
    RefersTo:="=OFFSET(Appointments!$A$2,0,0,COUNTA(Appointments!$A$2:$A$1000),COUNTA(Appointments!$1:$1))"

    And entered the following modified code

    Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim myCalItems As Outlook.Items
    Dim ItemstoCheck As Outlook.Items
    Dim ThisAppt As Outlook.AppointmentItem
    
    Dim MyItem As Object
    
    Dim StringToCheck As String
    
    Dim MyBook As Excel.Workbook
    Dim rngStart As Excel.Range
    
    Dim i As Long
    Dim NextRow As Long
    
    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, "Information"
      GoTo ExitProc
    End If
    
    If EndDate - StartDate > 31 Then
      If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
          GoTo ExitProc
      End If
    End If
    
    On Error Resume Next
    
    ActiveWorkbook.Names.Add Name:="Apps", _
    RefersTo:="=OFFSET(Appointments!$A$2,0,0,COUNTA(Appointments!$A$2:$A$1000),COUNTA(Appointments!$1:$1))"
    
      Set olApp = GetObject(, "Outlook.Application")
      If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
      End If
    On Error GoTo 0
    If olApp Is Nothing Then
      MsgBox "Cannot start Outlook. Please manually start Outlook.", vbExclamation
      GoTo ExitProc
    End If
    
    Set olNS = olApp.GetNamespace("MAPI")
    Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items
    
    ' ------------------------------------------------------------------
    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
    '
    Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
    Debug.Print ItemstoCheck.Count
    ' ------------------------------------------------------------------
    
    Call ClearAppointments
    
    If ItemstoCheck.Count > 0 Then
      If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
    
      Set rngStart = ThisWorkbook.Sheets("Appointments").Range("A1")
    
        With rngStart
        .Offset(0, 0).Value = "Subject"
        .Offset(0, 1).Value = "Category"
        .Offset(0, 2).Value = "Start Date"
        .Offset(0, 3).Value = "Start Time"
        .Offset(0, 4).Value = "End Time"
        .Offset(0, 5).Value = "Duration"
        End With
    
      For Each MyItem In ItemstoCheck
        If MyItem.Class = olAppointment Then
          Set ThisAppt = MyItem
          NextRow = ThisWorkbook.Sheets("Appointments").Cells(Rows.Count, 1).End(xlUp).Offset(0, 1).Row
    
          With rngStart
            .End(xlDown).End(xlUp).Offset(NextRow, 0).Value = ThisAppt.Subject
            .End(xlDown).End(xlUp).Offset(NextRow, 1).Value = ThisAppt.Categories
            .End(xlDown).End(xlUp).Offset(NextRow, 2).Value = Format(ThisAppt.Start, "ddd - DD/MMM/YYYY")
            .End(xlDown).End(xlUp).Offset(NextRow, 3).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
            .End(xlDown).End(xlUp).Offset(NextRow, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
            .End(xlDown).End(xlUp).Offset(NextRow, 5).Value = ThisAppt.Duration & " Minutes"
            ListBox1.RowSource = "Apps"
          End With
        End If
      Next MyItem
    
    Else
        MsgBox "There are no appointments or meetings during" & _
          "the time you specified.", vbCritical, "Information"
          GoTo ExitProc
    End If
    
    ExitProc:
    Set myCalItems = Nothing
    Set ItemstoCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Set rngStart = Nothing
    Set ThisAppt = Nothing
    End Sub

    This works brilliant and its very visual but how can i add when double clicked on a row in listbox1 it views the Outlook appointment selected, tried appt.display but no luck..

    Please can anyone help?

  44. You don't have a variable named 'appt' so 'appt.display' wouldn't do anything.

    Listboxes have a DblClick event that occurs when the listbox is double clicked. You would need to determine which item or items were selected when the user double clicks the listbox, then decide how you want to "view" the appointment. You can display the details in a messagebox, or create a separate userform with a textbox and show the form from your DblClick event.

  45. Matthew writes:

    Hi JP

    This dialogue is the most helpful I've ever seen. That being said, I too am a VBA newbie, and have a few questions. (1) why does John Hutchinson on Mar 25, 2009 set "Const olFolderCalendar = 9" (ie what is the significance of 9?) and (2) I get a compile error of olAppointment "variable not defined." Should I make John's modification?

    Thanks!!

  46. Matthew,

    If you don't set a (early bound) reference to the Outlook Object Library (via Tools » References in the VBIDE), you have to declare your Outlook objects As Object (late bound). You also can't use Outlook's enumerated constants, but only their numerical equivalents. So the answer to question 1 is that if you put back a constant with the same name and value as the Outlook constant, you can use the same syntax as if you had set that reference. It's a good trick, and if you later change to early bound, you can comment out the constants and otherwise not have to change your code at all.

    (2) olAppointment is another built in Outlook constant. Since we're checking the item's class, we'll need the constant value for the olAppointment class. If you change it to 26, the code should work. See the olObjectClass constant at http://msdn.microsoft.com/en-us/library/aa219371(office.11).aspx

    HTH

  47. Thanks for all this it's great. I searched high and low for an easy solution and this has saved me. However I need to pull out the labels from the appointments – Is it possible?

  48. What do you mean "labels" ? This code will extract the following.

    Subject
    Start Date
    Start Time
    End Date
    End Time
    Location
    Categories (if applicable)

    If you need more information from an appointment, you'll need to edit the code and add the properties you want to extract.

  49. Hi JP,

    I running outlook 2003 client on a exchange 2007 server and the I’m after the labels you can edit in 2003 client.
    For example you can colour a calendar item and “label” it important, personal etc.
    I don’t necessarily have to pull out the text from this field – I will happily take an integer, RGB value or anything but can’t seem to find the right code to pull it out.

    The code I have found just confused the heck out of me and isn’t as tidy as what you have here. Basically I am a VB amateur and am desperately trying to report on appointments in a number of calendars but the “Label” field is essential.

    Thanks in advance for any ideas!

  50. Matthew writes:

    Hi again JP

    Following up on DAH's question can the script extract custom labels? I have a custom form that provides a record of mileage on a particular event. When I substitute this label for "Location" in your code I still get the content from location. Is there a trick to referencing the content of the "milage" label to the heading?

    Matthew

  51. Matthew writes:

    Hold that thought. I missed the next reference to "Location" and once changed to my "Mileage" the script worked beautifully. How is works is still a mystery to me but that it works is wonderful. Thanks a million!

    Matthew

  52. DAH,

    I think I found your answer:

    http://www.outlookcode.com/codedetail.aspx?id=139

  53. Thanks JP, I have been trying to integrate that code but it looks as though it's a bit beyond me; i'll keep trying and post it if I get any success. Thanks again.

  54. Aziz, have you also got the "ClearAppointments" function somewhere which you use in your code? I did not find it anywhere here…

    regards,
    WM

  55. Wow, never expected to find such a fine piece of code!! I have been working with VBA for a couple of years previously but I am quite rusty nowadays. Therefore this piece gave me a huge headstart.

    As many others here I also need a variation to it and I am stuck, hoping for some insight here.

    I have designed a Custom Form to enter 4 user defined fields in addition to the normal Appointment data. I would like to pull these fields also into the Excel sheet, but have so far not found anything how to reference these fields.

    Can anybody push me into the right direction?

    with best regards,

    AK

  56. As usual when you sink in too much into a problem, you should step away and sleep over it :) After a good sleep I looked at it again and found the solution in an instant.

    For anybody interested, the custom fields can be referenced by ThisAppt.Userproperties("Custom Field Name")

    As I said, just needed some sleep :)

    with best regards
    AK

  57. Pratik Asthana writes:

    Hi,
    I develop VB.net 2008 with c# Application for fetch appoitment item from outllook 2003.
    I need to show the contact with their mobile number,which are stored in outlook contact
    related to the appointments in calender.

    [cc lang='csharp']
    int i = 0;
    Outlook.Application oApp = new Outlook.Application();
    Outlook.NameSpace oNS = oApp.GetNamespace("MAPI");
    oNS.Logon(Type.Missing, Type.Missing, false, true);
    Outlook.MAPIFolder Ocalender = oNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar);
    Outlook.Items oItems = Ocalender.Items ;
    int iNumContacts = oItems.Count;
    Outlook.AppointmentItem c = (Outlook.AppointmentItem)(oItems[1]);

    string sub = c.Subject;
    string body = c.Body;
    [/vb]

    If someone need more description abt this,kindly ask

    Plz. help
    Thanks in Advance
    Pratik Asthana

  58. Great Code!

    I'm using this to return the calendar items:

    For Each MyItem In ItemstoCheck
        If MyItem.Class = olAppointment Then
        ' MyItem is the appointment or meeting item we want,
       ' set obj reference to it
         Set ThisAppt = MyItem
         Dim CoLChk As Long
         CoLChk = Range("GetCalendar").column
          NextRow = WorksheetFunction.CountA(Columns(CoLChk))
    
          With rngStart
            .End(xlDown).End(xlUp).Offset(NextRow, 0).Value = ThisAppt.Subject
            .End(xlDown).End(xlUp).Offset(NextRow, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
            .End(xlDown).End(xlUp).Offset(NextRow, 2).Value = Format(ThisAppt.End, "MM/DD/YYYY")
            .End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.Location
          End With
        End If
      Next MyItem

    How can I also return the Label Property description with each item…ThisAppt.Label does not do it.

    Thanks
    Eric.

  59. Sue is my hero, goddess and idol all rolled into one.

    I had already done some work with extracting data from forms, and had someone ask if we can report on an Outlook booking system. I replied saying I knew it was possible and it would be just an extension of what I had done before. But of course I am extremely busy and can't commit to much. But I would, of course, have a play to see what I can do.

    One Google search, a cut and paste, and a very small tweak to make it work for me and I sent them back a response "Playtime over".

    My people want to set up a fleet booking system in Outlook and be able to report on it. Looks like I can deliver what they want and save our organisation thousands of dollars in the process.

  60. Actually JP – I must apologise. I thought the entire code was from Sue's book. I must ensure I include you in my directory of god-like creatures. :-)

    Eight weeks ago I had not even seen behind an outlook form. Plenty of Excel VB experience but nothing with the interfaces between the systems. This forum and others has given me the confidence to approach almost anything.

    Really appreciate it.

  61. Thank you much for the code – saved me a tremendous amount of time.

    I'm pulling data from a calendar what was populated with a form that has a combo box with two columns.

    The bound column is set to the first column (has to be) and I can retrieve the value stored from the input of the bound column with:

    … ThisAppt.UserProperties("Client")

    Is it possible to retrieve the value of the second column corresponding with the correct first column?

    Thank you so much.

  62. Gravey writes:

    I just wanted to say thanks so much to everyone once again. I've been writing VBA for excel for several years but in the last few months it has all just exploded. I know understand things that I never knew possible.

    From having an Outlook/Excel interface dumped on me, and then being asked to create something to allow our Procurement people to download an Outlook-based booking system for fleet vehicles into excel to extracting AD information, my head is still spinning.

    Your code, JP, stunned my colleagues when they asked me to deal with the booking system. I said I would have a look at it, and a a google lead me to your site, and within 5 minutes I was able to provide them with an example (that's yours) of what could be done.

    Sorry to hi-jack to post, but the only issue I am now struggling with is being able to extract all users from AD. There's plenty of sample code around for extracting individual user details, but I just can't make sense of it all to give me all current users in AD. The organisation should have around 3,500 users.

    I manage a system access report that pulls data from several operational systems and merges it with AD information, and I want to make sure I can always have up to date AD extracts without relying on anyone else. It has links through MS Query to a Sybase SQL database to get user information from one system, pulling tables out of another LDAP repository to get user information from another system, pulls in an extract from a third system, and then uses AD data to make it all make sense. This is an organisation with dozens of separate systems, hundreds of interfaces between systems, and over 70 interfaces to external organisations.

    • You may want to check out the CDO For Exchange object model. I can't seem to locate any good documentation, however.

  63. Gravey writes:

    One final thing (from me at least): Does it make a difference whether the Outlook object is a resource as opposed to a user? I would have thought not as they are both just GAL objects. Yes?

  64. Gravey writes:

    Sorry – ignore me. I just realised my folly.

    I was thinking that the GAL somehow distinguished between an object that could only be selected as a resource (say when booking a meeting) and a user.

    I think that we identify Resources by a prefix of "~". I'll just use that and go back to sleep.

    Many apologies.

    Thanks to you, I now have three different projects on the go that make use of some really nifty tricks. I have an feedback form that assigns itself a reference number by reading through all existing reference numbers in a mailbox, and when the response to the feedback is sent , it again reads through the mailbox to move all other forms with the same reference number to a completed folder. I am eternally grateful.

  65. snoopy writes:

    Hi,
    Wow great code! Thanx for sharing!

    I would like to add a filter to only retrieve the items with a special category (holidays).
    Unfortunately I've got errors caused by my German language settings:

    My filter:
    StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & " AND [End] <= " & _
    Quote(EndDate & " 11:59 PM") ' & " AND ([Kategorien] = 'Urlaub')"

    But I get no items at all (all filtered out)

    if I set it to [Categories] = 'Urlaub' I get an error saying "condition invalid"
    I think due to german language installation?

    Is there any way to fix this ? Maybe an code instead of clear naming "Categories"?

    By the way: Debug.Print ItemstoCheck.Count always returns the max number…
    If you want to count the filtered items you'll have to do it in a counting loop:

    Debug.Print ItemstoCheck.Count ' returns max number
    For Each obj In ItemstoCheck
    i = i + 1
    Next
    Debug.Print i 'returns real number of filtered items

    Best regards, once again thank you!!

  66. Hi JP,

    Great code, its really helpful. However, I'm having a problem access other users calendars.
    The calendar is in the folder:

    outlook:\\Mailbox – Smith, John\Calendar
    I've tried using:
    Set myCalItems = olNS.GetDefaultFolder(olFoldersAllPublicFolders).Folders("Mailbox – Smith, John").Folders("Calendar").Items

    It tells me "one or more parameter values are not valid".

    Do you have any suggestions?

    • You'll probably need to use:

      1. The GetSharedDefaultFolder Method

      i.e.
      olNS.GetSharedDefaultFolder(recipient, olFolderCalendar)

      Where 'recipient' is a Recipient Object that resolves to John Smith. If you don't have a Recipient object, create one using the CreateRecipient Method.

      olNS.GetSharedDefaultFolder(olNS.CreateRecipient("John Smith"), olFolderCalendar)

      or

      2. Walk through the folder hierarchy minus the default folder

      olNS.Folders("Mailbox – Smith, John").Folders("Calendar").Items

      • Hey JP,

        The getSharedDefaultFolder method worked. Thanks for the help. This will save us tons of time.

        • Hi!

          First of all this is a great code! But so far I have not been able to access shared calendars from Outlook. I've tried working my way through the hierachy :

          Set myCalItems = olNS.Folders("Mailbox – John Smith").Folders("Calendar").Items

          This actually works fine testing it on my own calendar, but I get an error when trying to acces shared calendars. Can anyone help me clarify what I'm doing wrong?

          I've also tried using the GetSharedDefaultFolder Method, but without any luck so far. It's only the public calendar where I have been able to find the path for.

          Loocking forward hearing from you!

  67. This code sounds fantastic for what i am wanting to do. Done some minor XL code for emails but never calendar stuff.
    Fairly experienced w/ Excel.
    Is this to be run from inside XL or Outlook? From the first portions of code I would think excel?
    I personally dont need the XL integration for what i want to do
    (which is iterate through calendar entries imported from MS project and set those created from it, and are multi day events to set the ALL DAY event to YES/TRUE) so it displays on my phone more clearly.

    • Finally got this to work by adding the reference? has the alternative revs been posted? I'd prefer an OLK version only cause i dont need to output to EXCEL…but otherwise this was terrific and got me nearly everythign I want to do….many thanks JP

      • This code is meant to be used inside Excel. It can easily be adapted to run inside Outlook using the technique found here:

        http://www.jpsoftwaretech.com/blog/2009/03/outlook-version-of-getdistlistmembers/

        • This page is great JP. Many thanks, I can not believe over years of searching I've not stumbled across this before. Outlook reference information is much harder to come by say versus Excel.

          I got this ported to pure Outlook I think.
          Got it doing what I wanted but came to realize it didnt help, due to phone.

          For your reference if interested, I have an iPhone and at work we're relegated to using MS Project. There is a web plugin that will import Project events into your Outlook Calendar. And I wanted to get events converted to ALL DAY tasks. This worked but unfortunately the iPhone does not interpret ALL DAY tasks when they SPAN more than one day in the DAY View of the native Calendar App.

          What I DID realize was that the iPhone can support multiple calendars / folders so I'm now trying to copy those appointements into a sub folder and then make an entry / day for any all day tasks so it manifests more clearly on my mobile.
          For example if I have a
          SERVER upgrade in MAIN Calendar that spans 5 days and are all day.
          I'd like to get 'Server upgrade' set in MAIN SUB Folder that is ALL DAY, but a single day for 5 days /ea

          If you have any insights I would welcome them.

        • I'm not clear on what you're trying to do. You want to convert certain appointments to tasks?

          "All Day" only applies to appointments/meetings, not tasks.

        • Sorry JP, probably semantics/miscommunicated. I realize OLK tasks are as such.
          To clarify, we are forced to schedule stuff via MS Project which myself colleagues dont care for.
          We all like to manage our times/schedules (and what work we need to focus on) via our OUTLOOK calendars.
          There is a MS OLK plugin that can import your MS Projects events/tasks into MS outlook as either tasks/calendar appts. Via PC the calendar looks fine, events that are ALL DAY show up isolated at the top vs hourly mtgs/appts.

          The appointements is what I (we'd) like, as you can see them via your Mobile phone.
          Personally I have an iPhone. The problem is the iPhone has 3 views, LIST / DAY / MONTH, the 1st and 3rd aren't very useful and while a weekly would be most optimum only the DAY is useful.
          The issue is the iPhone calendar doesnt process appointments that SPAN MULTI day appointments well. It does it differently / view.
          in the DAY view, it will color all 24 hrs w/ a appointment vs the thin "ALL DAY" listing of it. Then if you have multiple appointments it layers one of top of each other, making all of them unreadable.

          What I did find was the iphone calendar and palm's pre o/s do support MULTIPLE calendars. and seperate the calendars appointments by calendar.

          So what I was hoping was to have a VBA code, read my next monthy calendar appoinments in the default MAIN calender.
          if they are multiday events or (should be all day but wont be imported as such from the plugin)
          And make the necessariy individual ALL DAY appointements in the SECONDARY calendar to make it viewable via phone.
          So for example say i have an EVENT in calendar that is VACATION that is M 8am to F 5pm, in MAIN calendar.
          In the SECONDARY calendar I'd like to check for / if not create a entry VACATION – ALL DAY, for M / T / W / Th / F in that calendar so they are claerly identified in that calendar so the phone can process the way people like
          I'm not sure how easy or hard this would be I could see it being harder than envisioned or perhaps more simple than I think. I am not opposed to manually running this code manually as needed nor pre deleting the SECONDARY calendar if prechecking events is too difficult…as the plugin may update if a mtg or apptment changes, it may be easier to just purge the SECONDARY calendar and reprocess it every time (which may be easier to code was well)

          Is this any clearer? Maybe you could even tell me if possible or if way too difficult to be practical. I think you've done most of it, and the APPTs i'd want to process are clearly denoted from the plugin by the myItem.formdescriptin = "Project Web Appointment"

  68. Keith –
    I think I understand. You want to convert multiple-day appointments into single all-day appointments. I'll see what I can come up with.

    • JP, I haphazardly frankensteined your code and added what I needed and somehow got it to work …so far!
      I'd be happy to share, it probably could use some cleaning up… and think it would needlessly make this thread longer in the comments.

  69. JP,

    I used the code and it works perfectly for now, but i would like to add a field that gives me the name of the calender owner. How can this be achieved ?
    Next i tried to integrate the code written for Mary for collecting all calender items from different users into 1 excel sheet in an exchange 2003 environment, but was't able to get it working. Any thoughts on that one ?

    • If you are using GetSharedDefaultFolder to get someone else's Calendar, you have to know who that person is, because the method requires a Recipient object.

      What do you mean "wasn't able to get it working"? You'll need to be more specific.

  70. Wonderful Code JP,
    Being this is my first week ever using VB i found it very helpful!
    I used the original code you posted and then implemented various things throughout the posts like popup box for the dates and such. I have seen some people ask this before, but I dont know if an answer was really given yet.

    What I am trying to do is when you run the macro I want it to search multiple personal (shared) calendars. I have gotten the code to work on defaults and on public items but only one calendar at a time.

    Would it be possible to use an array that contains all the (peoples names) for the calendars that I want to search through? This whey you only have to run the macro once to pull information from say like 10 calendars.

    Then if it would be possible post that persons name somewhere so we know whos information is what on the excelsheet.

    Any help or point in the right direction would be awesome!

  71. phxphun writes:

    Great stuff, JP! Thanks for sharing.

    Could it be modified to import Tasks into Excel?

    • phxphun writes:

      Oops, nevermind. I found your "Export Outlook Tasks to Excel" blog. That did the trick perfectly! Thanks again.

This article is closed to any future comments.
Random Data Generator