How to bulk Export all public shared calendars from outlook 2010 to a csv?

Question

I have a requirement now to export all calendars in my Public Shared Folder in Outlook 2010 to a .csv so that it can be later imported into an MS Access database.

I have just the view permission to these shared calenders and so, most of the menu options are faded/inactive. I tried several blogs and addins but nothing works. Is there a way to make this happen ? If not, I have to manually copy more than 100+ calendars one by one to individual .csvs and then copy paste to an Excel, then do an import in MS Access.

Answer 1

Instead of exporting and then importing the required data you may consider automating Outlook from Access. The How to automate Outlook from another program article describes all the required steps.

You may find the following sample code helpful (listed in the VBA script to export Calendar to PST and CSV forum thread):

 Sub ExportAppointmentsToCSVFile()
  On Error Resume Next
  'You must set a reference to the Microsoft Scripting Runtime library to use the FileSystemObject
  Dim objNS As Outlook.NameSpace
  Dim objAppointments As Outlook.Items, objCalendarFolder As Outlook.MAPIFolder
  Dim objAppointment As Outlook.AppointmentItem
  Dim objFS As Scripting.FileSystemObject, objOutputFile As Scripting.TextStream
  Set objNS = Application.GetNamespace("MAPI")
  Set objCalendarFolder = objNS.GetDefaultFolder(olFolderCalendar)
  Set objAppointments = objCalendarFolder.Items
  Set objFS = New Scripting.FileSystemObject
  Set objOutputFile = objFS.OpenTextFile("C:\Temp\AppointmentExport.csv", ForWriting _
  , True)
  'Write header line 
  objOutputFile.WriteLine "Subject,Start,End"
  For Each objAppointment In objAppointments
    objOutputFile.WriteLine objAppointment.Subject & "," & objAppointment.Start & "," & objAppointment.End
  Next
  objOutputFile.Close
  Set objNS = Nothing
  Set objAppointment = Nothing
  Set objAppointments = Nothing
  Set objCalendarFolder = Nothing
  Set objFS = Nothing
  Set objOutputFile = Nothing
End Sub

Sub CopyItemsToFolder()
  On Error Resume Next
  Dim objNS As Outlook.NameSpace
  Dim objSourceItems As Outlook.Items
  Dim objSourceItem As Object, objCopy As Object
  Dim objSourceFolder As Outlook.MAPIFolder
  Dim objDestinationFolder As Outlook.MAPIFolder
  Dim blnCopyFolder As Boolean
  Set objNS = Application.GetNamespace("MAPI")
  MsgBox "In the next dialog, please select the source folder containing the items you want to copy...", vbOKOnly
  Set objSourceFolder = objNS.PickFolder
  If objSourceFolder Is Nothing Then GoTo Exitt: 'User cancelled
  If MsgBox("Do you wish to copy the entire folder? Click 'No' to copy just the contents of the folder. Otherwise, all subfolders" _
  & " will also be copied.", vbYesNo + vbQuestion, "Select Copy Type") = vbYes Then
    blnCopyFolder = True
    MsgBox "In the next dialog, please select the parent folder where you want the new folder copied to...", vbOKOnly
  Else
    MsgBox "In the next dialog, please select the destination folder where you want the folder items copied to...", vbOKOnly
  End If
  Set objDestinationFolder = objNS.PickFolder
  If objDestinationFolder Is Nothing Then GoTo Exitt: 'User cancelled
  If objDestinationFolder.DefaultItemType <> objSourceFolder.DefaultItemType Then
    If blnCopyFolder = False Then
      MsgBox "Please pick a destination folder that is of the same default item type as the source folder." _
      , vbOKOnly + vbExclamation, "Invalid Folder"
      GoTo Exitt:
    End If
  End If
  If blnCopyFolder = True Then
    objSourceFolder.CopyTo objDestinationFolder
  Else
    Set objSourceItems = objSourceFolder.Items
    For Each objSourceItem In objSourceItems
      Set objCopy = objSourceItem.Copy
      objCopy.Move objDestinationFolder
    Next
  End If
  MsgBox "Copy complete."
Exitt:
  Set objNS = Nothing
  Set objCopy = Nothing
  Set objSourceFolder = Nothing
  Set objSourceItem = Nothing
  Set objSourceItems = Nothing
  Set objDestinationFolder = Nothing
End Sub