Copying shared Calendar Appointments from outlook into Excel with VBA

[RobP]

Hi all,

I am using Office 365 Pro Plus build 1912 (but it also ran on build 1902 or 1904 before I upgraded recently).
My macro is written to interrogate my own, and shared calendars with me from outlook - and bring the appointments into Excel in a list.

It works beautifully on my own machine - I can grab data from each calendar in turn. However, when I pass my excel file to a colleague for him (actually tried 2 different people) to run the macro on his machine (same build config etc.) - it runs into problems.

The code appears to execute as expected (in that it takes some time to grab this years and last years data), and then completes once its done, without displaying any of the data. We are currently remote, so I've not tried stepping through the code on their machines to see what its doing yet - but on the face of it - it appears to be running correctly - just not fetching the Outlook Calendar data.

I have set the Outlook Object reference (16.0) in the developer/Tools/References on their machines accordingly.

Can I ask, Are there any other settings that I need to have done on their machines in order for this to function ?

I've been using macros on my machines for a long time - so wondered if I'd set something some time ago that I'd forgotten about recently.... I'll paste a section of my code here, just for reference.

Option Explicit
Public R As Long
Public SelectedCalendar As String
' ********************************************************************************
' *   Interrogate Outlook calendars for all external meetings & populate
' *   Excel database with attendees coming down the columns for each appt.
' **********************************************************************************

Sub outlook_calendaritemsexport()

Dim C As Long, i As Long,  lrow As Long
Dim appt_id As Long,  append_row As Long
Dim data_array() As Variant, start_time As Variant

Dim myfol As Outlook.Folder
Dim ons As Outlook.Namespace
Dim o As Outlook.Application
Dim myapt As Outlook.AppointmentItem
Dim myrpnt As Outlook.Recipient
Dim oEU As Object

Set o = New Outlook.Application
Set ons = o.GetNamespace("MAPI")

start_time = Now()

Sheets("Data").Activate

'Show UserForm here. UserForm is a simple box with names of shared calendars, which gets stored into "SelectedCalendar" upon selection. R is also set to 5 (start row on my sheet), or last row after current data
UserForm1.Show

'Setup 'Subroutine to Setup column widths / colors etc

append_row = R 'use this to know where to append the new data onto screen for an appended search.. R comes from UserForm.

Dim myRecipient As Outlook.Recipient

'selected in the userform ComboBox list
If SelectedCalendar = "Select Calendar" Then 'nobody selected, so operate on your own calendar
    Set myfol = ons.GetDefaultFolder(olFolderCalendar) 'Set this to work on own folder
Else
    Set myRecipient = ons.CreateRecipient(SelectedCalendar)
    myRecipient.Resolve

    If myRecipient.Resolved Then
            Set myfol = ons.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
        Else
            MsgBox ("Calendar Issue, Program Halted")
            End  'end if calendar not resolved
    End If
End If

Range("A4:N4").Value = Array("DATE", "CUSTOMER", "SUBJECT", "LOCATION", "CUSTOMER TYPE or DISTRIBUTOR MEETING", "FACE To FACE / TEAMS", "DISTRIBUTOR Or ALONE", "DISTRIBUTOR VISIT TYPE", "CUSTOMER ATTENDEES", "DISTRIBUTOR ATTENDEES", "OUR ATTENDEES", "REQUIRED ATTENDEES", "CALENDAR OWNER", "MEET ID")

'check calendar has some items inside / is shared

On Error GoTo ErrorHandler

lrow = 0 'array row start)
ReDim Preserve data_array(1 To 14, lrow) '(be aware the array is transposed, as ReDim Preserve only works on last dimension)

'***  GET THIS DYNAMICALLY FROM LAST ROW OF DATA (comes from userform button) in case of New, or Appended data search *****
If R = 5 Then
    appt_id = 1 'set first appointment ID number
Else
    appt_id = Cells(R - 1, 14).Value + 1
End If


R = 0 ' now reset R as first row in array

For Each myapt In myfol.Items 'check each calendar Appointment) Then
  
    'Year(Now())   Year(Now())-1  this year last year
  If InStr(myapt.Start, Year(Now())) > 0 Or InStr(myapt.Start, (Year(Now())) - 1) > 0 Then ' if appt is this year/last year
  
   
    data_array(1, R) = myapt.Start
   
    data_array(3, R) = myapt.Subject
   
    data_array(4, R) = myapt.Location
    
    data_array(12, R) = LCase(myapt.RequiredAttendees)
 
    data_array(13, R) = SelectedCalendar
 
    data_array(14, R) = appt_id
    
    appt_id = appt_id + 1 ' update appointment ID code

     ReDim Preserve data_array(1 To 14, R + 1) 

     R = R + 1 
 End If 'End Appt year checking

Next 'Calendar Appointment

Set o = Nothing
Set ons = Nothing
Set myfol = Nothing
Set myapt = Nothing
Set myrpnt = Nothing

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

'store data on screen
Range(Cells(append_row, 1), Cells(append_row + UBound(data_array, 2), 14)) = TransposeArray(data_array) 'function to transpose data back into rows due to RedimPreserve operating across only


MsgBox ("start : " & start_time & "  finish : " & Now())

Erase data_array


End

ErrorHandler:
    MsgBox ("Calendar Not Shared")
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    End

End Sub

 

[RobP]

Hi all, actually I've managed to debug the issue. Stepping through the code on the 2nd machine showed that the calendar was in fact being interrogated, and data was retrieved. but the critical line was :

If InStr(myapt.Start, Year(Now())) > 0 Or InStr(myapt.Start, (Year(Now())) - 1) > 0 Then ' if appt is this year/last year

It was never finding 2019, or 2020 appointments, so never showing any data. Reason being - my colleagues had different date formatting on their machines to mine, so where above I was looking to find the strings "2019" or "2020" in the appointment Start time (14/04/20 10:45) - it would never show up as this is a 2 digit format, to my (mm-dd-yyyy) format.

so I changed the code (for the better) to this instead :

If Year(myapt.Start) = Year(Now()) Or Year(myapt.Start) = (Year(Now()) - 1) Then '

This operates independent of date format setup you have in Windows.

 

[MickP69]

Hi RobP, I have been trawling the internet trying to find a solution to getting data into excel from a Shared Calendar.
I've tried to use your code but do I need anything else to make this run?

I did hit an hit issue with TransposeArray as I am running 2016 but I have got passed that.

'store data on screen
Range(Cells(append_row, 1), Cells(append_row + UBound(data_array, 2), 14)) = Application.WorksheetFunction.Transpose(data_array) 'function to transpose data back into rows due to RedimPreserve operating across only

I've created a blank UserForm1 but it hangs when the code shows this form.

Any ideas would really appreciate any help.
You are the first one I have found that has anything remotely like I need.

Thanks,
Michael.

 

[RobP]

Hi Michael,
its the first time I've been asked to provide answers here - rather than be the guy looking for answers - so I guess its good to have finally contributed, rather than just taken from this board for a change (assuming you can get it working). The downside is I'm not really the expert - and its been a long time since I looked or remember what the code was doing but I did get it working back then (for me).

The UserForm was a simple one, hopefully uploaded below for you to see - but there is also code within it - to populate the drop down box with the names (actually email addresses) of the persons calendar that was to be interrogated. It gets this list from a worksheet I have in the file called "Lists", and the list of emails was put in Col K starting Row 2 (Row 1 was a heading). As I wanted to interrogate several peoples calendars one at a time, I put the option in the userform1 to allow me to Append each users data to the bottom of my data list, or indeed wipe my data, and start a New search. (So lets say once a month I can start a new search with the first user, then simply append all the others to the bottom of my list with these 2 buttons). If it is just your own calendar to interrogate - just put your own email address in "Lists" / Cell K2. If you have others, put them in K3, K4 etc.. but importantly to look at others - they MUST have shared their calendar with you with FULL read write Access - but I'd recommend playing just with your own calendar before going near others, as you'll have no linking trouble on your own data. Code I have in my userform is posted below:

Private Sub UserForm_Initialize()


Dim lastrow As Long, count As Long


UserForm1.ComboBox1.Clear


lastrow = Sheets("Lists").Cells(Rows.count, 11).End(xlUp).row ' get last cell no. in list.
count = 2 'set first row of data


Do 'populate ComboBox1 with calendar names from lists sheet.
    UserForm1.ComboBox1.AddItem (Sheets("Lists").Cells(count, 11))
    count = count + 1
    
Loop Until count > lastrow


UserForm1.ComboBox1.Value = "Select Calendar"


End Sub
Private Sub ComboBox1_Change()


SelectedCalendar = UserForm1.ComboBox1.Value


End Sub


Private Sub CommandButton1_Click()
    Unload Me
    End 'Cancel Selected
    
End Sub


Private Sub CommandButton2_Click()
' Add new data to existing DBase
R = (Sheets("Data").Cells(Rows.count, 1).End(xlUp).row) + 1


Unload Me
End Sub


Private Sub CommandButton3_Click()
' Start a New Search / Clear Data
Sheets("Data").Cells.ClearContents
R = 5
Unload Me
End Sub

 

[MickP69]

Hi Rob,

I have browsed this board for many years and just signed up today when I came across your post.
After I replied I did worry if I would ever get a response let alone the same day.
So I am very grateful for your feedback.

I have added the Userform which is obviously blank so I will give this a go.
My current scenario revolves around shared calendar or resources so getting this data to analyse is paramount for my task.

I will feedback how I get on, again much appreciated.

Michael.

 

[MickP69]

Hi Rob,

I have managed to get that to work with Excel 2016, however it will not pull in my calendar.
Like you suggested I have added the calendar email address to the list which shows up in the drop down.
After a short pause it comes back with calendar not shared message box.
So close I can almost touch it.
The resource in question I already have access to so I am confused as to why I cannot use it?

Thanks,
Michael.

 

[RobP]

Hi Michael,
are you able to step through the code - to see at which line you get the error handler triggering ?

Maybe also , if you actually don't select anything in the UserFOrm1, just leave it as "Select Calendar", and continue skipping through the code - can you see what actually gets stored in the variable "myfol" when it tries to select the calendar ? In theory it should contain "Calendar" which effectively means its going to use your outlook calendar. ?

thanks
Rob

 

[RobP]

Hi Michael,
are you able to step through the code - to see at which line you get the error handler triggering ?

Maybe also , if you actually don't select anything in the UserFOrm1, just leave it as "Select Calendar", and continue skipping through the code - can you see what actually gets stored in the variable "myfol" when it tries to select the calendar ? In theory it should contain "Calendar" which effectively means its going to use your outlook calendar. ?

thanks
Rob

(I should say, leave the UserForm1 as Select Calendar, and hit "New Search" of course...)

 

[MickP69]

Hi Rob,
Sorry for the delay.

Ok I tried stepping through it as "Select Calendar" and got all the the way to the end fine.

Tried again selecting the shared calendar and stepped through this time I saw that it did actually Resolve the correct address and continued.
I watched it loop through the array 117 times so, 117 rows of data I would assume.

it gets to;

'store data on screen
Range(Cells(append_row, 1), Cells(append_row + UBound(data_array, 2), 14)) = Application.WorksheetFunction.Transpose(data_array) 'function to transpose data back into rows due to RedimPreserve operating across only

Then drops into "ErrorHandler" and displayed message box "Calendar Not Shared".

In both instances variable "myfol" contained "Calendar"

 

[MickP69]

I now have "owner" privileges on this shared calendar and still the same.