Export shared calendars data to Excel

[colombiano25]

Hello guys!

I'm working on vba script which is supposed to export some interesting data from Outlook to Excel.
The task is to realise a script that, given a set of shared calendars on Exchange, writes on an Excel sheet the employes that are on vacation.

So basically the end user put a start date and an end date and the result would be a set of rows "Employee - Start date - End date" with the meaning "this employee is in vacation from %DATE until %DATE". Ecery employee has to set an appointment with location "vacation" in order to declare his/her willing to take an holiday.

I adapted a script that i've found on internet some days ago, it works but only in local. I have no idea how to iterate on shared calendars... Would you help me to add the trunk of code whom will make everything work?

Private Sub Test_Click()
Call GetCalData("16/06/2015", "28/06/2015")
End Sub
 
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
 
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 = ThisWorkbook
  Set rngStart = ThisWorkbook.Sheets(1).Range("A1")
  With rngStart
    .Offset(0, 0).Value = "Employee"
    .Offset(0, 1).Value = "Start date"
    .Offset(0, 2).Value = "End date"
    .Offset(0, 3).Value = "Location - debug"
 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
     If StrComp(ThisAppt.Location, "vacation") = 0 Then
        NextRow = Range("A" & Rows.Count).End(xlUp).Row
With rngStart
.Offset(NextRow, 0).Value = ThisAppt.Organizer
.Offset(NextRow, 1).Value = ThisAppt.Start
.Offset(NextRow, 2).Value = ThisAppt.End
.Offset(NextRow, 3).Value = ThisAppt.Location
      End With
    End If
   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("A18:AE18")
'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

Thanks for reading and have a nice day

[skatonni]

See here http://www.slipstick.com/developer/w...tlook-folders/

"To access a shared folder in another user's Exchange server mailbox, you need to use GetSharedDefaultFolder to reference the mailbox, after resolving the address to the folder.

You can use the mailbox owner's display name, alias, or email address when resolving the recipient."

Dim NS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
 
Set NS = Application.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("maryc")
    objOwner.Resolve
If objOwner.Resolved Then
    'MsgBox objOwner.Name
    Set newCalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If

[colombiano25]

What if I have to iterate to multiple users? Do I need to know their names before? Thanks

[adamgaves]

Hello
You can easily select one or more calendar and extract all of them from outlook into the desired folder, as well as you can delete unwanted calendar sheet that take too much disk space in your mailbox. I have used many softwares but one software I have used is very good that software is simple and easy to used you can extract any Calendars, email address, attachments, contacts, etc.


Thanks