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 Michael,

might have hit the nail on the head - I just realised you didn't have the Function from the line that it fails on.... doh ! Try adding this function also to your module and see how it goes.

cheers
Rob

Public Function TransposeArray(myArray As Variant) As Variant
Dim x As Long
Dim Y As Long
Dim Xupper As Long
Dim Yupper As Long
Dim tempArray As Variant
    Xupper = UBound(myArray, 2)
    Yupper = UBound(myArray, 1)
    ReDim tempArray(Xupper, Yupper)
    For x = 0 To Xupper
        For Y = 1 To Yupper 'fixed 1-14
            tempArray(x, Y - 1) = myArray(Y, x) 'confusion as temp array starts at 0 both dimensions, myarray has 1-14 and 0-xxxx, so remap to zero base
        Next Y
    Next x
    TransposeArray = tempArray
End Function

 

[MickP69]

Hi Rob,

That did in fact fix the problem which is fantastic.
I now need to tweak the fields you are retrieving to fit with my scenario.

Many thanks,
Michael.

 

[RobP]

No problem - glad to have been of help..

Rgds
Rob

 

[MickP69]

Hi Rob,

I am still kicking this around and have another question if I may.
I've made a couple of changes with the array data being retrieved as shown below.

My question is more to do with the date of the appointments;
How hard would it be to change this to make it use a Start date to End Date?
I've tried a couple of things that simply failed.

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.Subject
   
    data_array(2, R) = myapt.Start
    
    data_array(3, R) = myapt.End
   
    data_array(4, R) = myapt.Duration
    
    data_array(5, R) = myapt.Location
    
    data_array(6, R) = myapt.MeetingStatus
    
    data_array(7, R) = myapt.AllDayEvent
    
    data_array(8, R) = myapt.Organizer
    
    data_array(9, R) = myapt.Importance
    
    data_array(10, R) = LCase(myapt.RequiredAttendees)
 
    data_array(11, R) = myRecipient

Many thanks,
Michael.

 

[RobP]

Hi Rob,

I am still kicking this around and have another question if I may.
I've made a couple of changes with the array data being retrieved as shown below.

My question is more to do with the date of the appointments;
How hard would it be to change this to make it use a Start date to End Date?
I've tried a couple of things that simply failed.

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.Subject
  
    data_array(2, R) = myapt.Start
   
    data_array(3, R) = myapt.End
  
    data_array(4, R) = myapt.Duration
   
    data_array(5, R) = myapt.Location
   
    data_array(6, R) = myapt.MeetingStatus
   
    data_array(7, R) = myapt.AllDayEvent
   
    data_array(8, R) = myapt.Organizer
   
    data_array(9, R) = myapt.Importance
   
    data_array(10, R) = LCase(myapt.RequiredAttendees)

    data_array(11, R) = myRecipient

Many thanks,
Michael.

Hi Michael,
when you say "use a Start Date to End Date" - could you clarify please ?
When I simply replace myapt.Start with myapt.End - I can see that the data shows the date & scheduled finish time of the meeting from outlook on my side ? (eg. if the meeting time was scheduled as 1 hour at 09:00am, the data would show 10:00am as expected.
Is that not what you are looking for please ?
Many Thanks
Rob

 

[MickP69]

I am thinking from say from Jan 1st 2021 to end of July 2021 just for an example.
Is there a particular format this needs to be in.

 

[RobP]

I am thinking from say from Jan 1st 2021 to end of July 2021 just for an example.
Is there a particular format this needs to be in.

Hi Michael,

well, my apologies, but I'm still not understanding really what you are trying to store where - looking at your code above would suggest that you have the start date, and the end date, and also the duration in days stored in your columns, right ?

How would you like to see this "start date to end date" in your cell finally ? are you talking about just concatenating the 2 together please ?

Many thanks
Rob

 

[RobP]

Hi Michael,
if you are storing both dates (start and end) into one cell (or array location), you can use

data_array(2, R) = myapt.Start & myapt.End

and this will give you a result looking like : 16/01/2020 13:00:0016/01/2020 14:00:00
which is a little unsightly, as there is no gap between them.

In this case use

 & "<SPACE>" &

in between them.

If my understanding of your need has not been grasped - please take some time to explain further what you trying to do overal, and I'll do my best to help.
cheers
Rob

 

[MickP69]

Hi Rob,

Basically I want a user to be able to choose a start and end date in excel prior to requesting the appointment records.
So really its more about using those dates in this;

 '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

The different elements in the array you can ignore, I am simply using them in a data model then using power pivot.
It is working quite well but when I refreshed it yesterday it seemed to ignore items with the same name on the export.

Thanks,
Michael

 

[RobP]

Hi Rob,

Basically I want a user to be able to choose a start and end date in excel prior to requesting the appointment records.
So really its more about using those dates in this;

'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

The different elements in the array you can ignore, I am simply using them in a data model then using power pivot.
It is working quite well but when I refreshed it yesterday it seemed to ignore items with the same name on the export.

Thanks,
Michael

Hi Michael,

OK, understood - I've just formatted cell C3 (Start Date) and D3 (End Date) as "Short Date" on my sheet, and put a start date and end date in ("12/06/20") for example. - then just used this:

If myapt.Start >= Range("C3").Value And myapt.End <= Range("D3").Value Then

Seems to work okay, but of course I'd advise you build in some checking of the user entries (to make sure they are valid dates - perhaps use IsDate() ? , and also to make sure the start is before the end date - else you'll get no data.
I will also comment that sometimes during debugging etc. this interaction with Outlook seems to hang (or in my case, sometimes appears not to run at all..) . at which point I recommend shutting down both apps, and reloading. Not sure why they go awry.. but I've experienced it a few times when I was developing it in the past..
Cheers
Rob