VBA, export public calendar data from outlook 2010 in format usable by excel

[renigar]

Hi All,
I know little to nothing about VBA in Outlook, but have found the code below that works pretty good except it outputs as an
ics (icalendar) file. I would like it to output as a csv file or something compatible with Excel if possible. I also need it to pull the data from a public folder calendar that has the following path in my outlook folder list: \\Public Folders - myemailaddress.gov\All Public Folders\City of Workplace\Bulletin Boards\Utilities and the name of the calendar is: Time Off Schedule. Right now it grabs the data from the default calendar. I haven't found a good way to open or use the ics file in excel. I like that this code lets you select the start and end date range to export. As always any help is greatly appreciated.

The following code was posted by Shirley Zhang at datanumen.com

To reiterate:
1. Can the output file be changed to something Excel compatible?
2. Can the data be exported from a public calendar?

Sub ExportCalender_inSpecificDateRange_AsiCalendarFile()
    Dim objCalendarFolder As Outlook.Folder
    Dim objCalendarExporter As Outlook.CalendarSharing
    Dim dStartDate As Date
    Dim dEndDate As Date
    Dim objShell As Object
    Dim objSavingFolder As Object
    Dim strSavingFolder As String
    Dim striCalendarFile As String
 
    'Get the current Calendar folder
    Set objCalendarFolder = Outlook.Application.ActiveExplorer.CurrentFolder
 
    If Not objCalendarFolder Is Nothing And objCalendarFolder.DefaultItemType = olAppointmentItem Then
       Set objCalendarExporter = objCalendarFolder.GetCalendarExporter
 
       'Enter the specific start date and end date
       dStartDate = InputBox("Enter the start date, such as 7/1/2017:", "Specify Start Date")
       dEndDate = InputBox("Enter the end date, such as 8/31/2017:", "Specify End Date")
 
       If dStartDate <> #1/1/4501# And dEndDate <> #1/1/4501# Then
          'Select a Windows folder for saving the exported iCalendar file
          Set objShell = CreateObject("Shell.Application")
          Set objSavingFolder = objShell.BrowseForFolder(0, "Select a folder:", 0, "")
          strSavingFolder = objSavingFolder.self.Path
 
          If strSavingFolder <> "" Then
             striCalendarFile = strSavingFolder & "\" & "Calendar from " & Format(dStartDate, "YYYY-MM-DD") & " to " & Format(dEndDate, "YYYY-MM-DD") & ".ics"
 
             'Export the calendar in specific date range
             With objCalendarExporter
                  .IncludeWholeCalendar = False
                  .StartDate = dStartDate
                  .EndDate = dEndDate
                  .CalendarDetail = olFullDetails
                  .IncludeAttachments = True
                  .IncludePrivateDetails = False
                  .RestrictToWorkingHours = False
                  .SaveAsICal striCalendarFile
             End With
 
            MsgBox "Calendar Exported Successfully!", vbInformation
          End If
      Else
          MsgBox "Open a calendar folder, please!", vbExclamation + vbOKOnly
      End If
    End If
End Sub

Thanks,
renigar

 

[SkipVought]

Hi,

This is gonna take YOU to a new level of programming.

First, here's a pretty simple procedure that loops thru a calendar folder, in this case [tt] GetDefaultFolder(9)[/tt]. If you run this one in Excel, it will write the data into the active sheet.

https://www.ozgrid.com/forum/index.php?thread/113789-macro-to-export-outlook-calendar-to-excel/

BUT, that is probably not the calendar of interest. So, yer gonna have to do some searching to find the right one. That's where using the Watch Window comes in handy. I've used this to find my way around applications that I have very little knowledge of, like Outlook.
Faq707-4594

HINTS:
You may be able to look at the olNS object in the WW, looking for Folders. Opening any Folder object, look for a Name property, for instance, that might identify your calendar.

You might be able to look an individual folder object olNS.GetDefaultFolder(9) other than 9.

Good luck

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]
"The most incomprehensible thing about the universe is that it is comprehensible" A. Einstein

 

[renigar]

Thanks for commenting Skip. This is what I'm using. It works, but I definitely have not reached a new level of programming. I found very little info on Outlook VBA that makes it understandable to me. My solution is two parts (code listed below). The first macro is an Outlook macro I found on the web, but forgot to note where. Thanks to whoever originally put it out there. This code gets the folder ID of the folder you select.

Outlook macro:

Sub entryIDFromPickfolder()
' Outlook macro
' This macro will return the EntryID of a folder you pick in Outlook

' It opens a window where you select the folder,
'  then it returns the Outlook folder ID

Dim oFolderPicked As Folder

Dim entryIDStr As String

Dim uPrompt As String
Dim uTitle As String
Dim uDefault As String
Dim msg As String

Set oFolderPicked = Session.PickFolder

If Not oFolderPicked Is Nothing Then

    entryIDStr = oFolderPicked.EntryID

    uPrompt = "To hardcode the entryID of the " & _
              Session.GetFolderFromID(entryIDStr) & _
              " folder, copy this ID"

    ' Copy from the immediate pane
    Debug.Print uPrompt
    Debug.Print entryIDStr

    Set ActiveExplorer.CurrentFolder = Session.GetFolderFromID(entryIDStr)
    DoEvents

    uTitle = Session.GetFolderFromID(entryIDStr)
    uDefault = entryIDStr

    msg = InputBox(Prompt:=uPrompt, Title:=uTitle, Default:=uDefault)

End If

ExitRoutine:
    Set oFolderPicked = Nothing

End Sub

This next code is an Excel macro that I got off the web (again forgot to note where, but thanks anyway) and modified. This macro gets the date from a cell I have on the worksheet then pulls 5 days of appointments from the calendar. On my computer it gets the 5 days of appointments pretty fast but seems to keep checking something. The process takes over a minute to complete. I feel it could go faster but since I don't quite know what I'm doing I don't know how to improve it.

Excel macro:

Sub ListTimeOffWeek1()

' Excel macro to list appointment info to a work sheet from an outlook calendar
' I found several versions of this macro online and made slight modifications
' This macro does not list recurring entries!

Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olApt As Object
Dim NextRow As Long
Dim FromDate As Date
Dim ToDate As Date
Dim LastRow As Long
Dim cell As Object
Dim TOD As Variant
Dim tOff As Variant
Dim T As Integer
Dim c As Integer
Dim r As Integer
Dim wsN1 As String
    
' Get the specific start date and end date
' This is set to get 5 days of data
    FromDate = Cells(1, 3)
    ToDate = FromDate + 4
    If FromDate = False Then Exit Sub
    
' Convert work week start date to a number
TOD = Day(FromDate)

' Copy Friday time off data to Previous Friday
    Range("T3:W10").Copy
    Range("AQ3:AT10").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

' Delete previous Time Off entries from Duty Shedule Week-1 sheet
    Range("D3:W10").ClearContents
    
    Worksheets("Time Off Wk1").Activate
    
' Delete previous Time Off imported data from Time Off Wk1 sheet
    Range("A1:E50").ClearContents
    
' Put message on page to wait while macro processes
    Range("F2,F4,F6,F8").Select
    With Selection.Font
        .Color = -16776961 ' Red
        .TintAndShade = 0
        .Bold = True
    End With
    Range("F2,F4,F6,F8").Value = "Please wait while macro processes!"
    Range("F3,F5,F7,F9").Value = "This could take over a minute..."
    Range("A1").Select

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0

' Set calendar to get info from. I used outlook macro to get calendar ID (Outlook macro name: entryIDFromPickfolder)
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetFolderFromID("000000001A447390AA6611CD9BC800AA002FC45A03001BAF977454EB5C4C8317C16899AEB63900000007869D0000") ' ID of the shared public calendar to use
    NextRow = 2

    With Sheets("Time Off Wk1") 'Change the name of the sheet here
        .Range("A1:D1").Value = Array("Employee", "Date", "Code", "Hours") ' Headers I use later
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then  ' There were other appointment fields here, but I didn't need them
                .Cells(NextRow, "A").Value = olApt.Subject
                .Cells(NextRow, "B").Value = CDate(olApt.Start)
                NextRow = NextRow + 1
            Else
            End If
        Next olApt
        .Columns.AutoFit
    End With

' Clear Variables
    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    
' Swap columns A & B
    Columns("B:B").Cut
    Columns("A:A").Insert Shift:=xlToRight
    
' Autofit Column A
    Columns("A:B").EntireColumn.AutoFit

' Insert blank row at row 1
    Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
' Insert date range info into 1st row
Range("A1").Value = "Data from Time Off Calendar date range " & FromDate & " To " & ToDate


End Sub

There is more code in the macro (not listed here) mostly to do with formatting the results and placing on the worksheet.
Any comments or suggested are welcomed.
Renigar