Copying shared Calendar Appointments from outlook into Excel with VBA

RobP

Board Regular
Joined
May 8, 2008
Messages
55
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.

VBA Code:
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
 

Some videos you may like

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

RobP

Board Regular
Joined
May 8, 2008
Messages
55
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 :
VBA Code:
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 :
VBA Code:
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,119,290
Messages
5,577,218
Members
412,777
Latest member
jmulldome
Top