Unable to iterate over other person's appointments with VBA - vba

Question

I am trying to iterate over someone's outlook appointments with VBA. I believe the following fragment should do what I need, however, the line for each appm in cal.items pops up a little message box that says
Laufzeitfehler '-140492795 (f7a04405)':
Automatisierungsfehler
In english, that would probably be run time error .... automation error.
Why do I get this error?
option explicit
sub abcdef()
dim ol as outlook.application
dim ns as outlook.namespace
dim rcpt as outlook.recipient
dim cal as outlook.folder
dim appm as outlook.appointmentItem
set ol = new outlook.application
set ns = ol.GetNamespace("MAPI")
set rcpt = ns.createRecipient("Deere John")
rcpt.resolve
if not rcpt.resolved then
msgBox("Could not resolve recipient")
return
end if
set cal = ns.getSharedDefaultFolder(rcpt, olFolderCalendar)
if cal is nothing then
msgBox ("No Calender!")
return
end if
for each appm in cal.items
' Error occurs in previous line
next appm
end sub

Answer 1

Found some code here: http://www.slipstick.com/developer/copy-new-appointments-to-another-calendar-using-vba/ which would change how you dim appm... Instead of outlook.appointmentItem it has it simply as appointmentItem. So Dim appm as appoointmentItem
Edit: Their syntax also uses Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test") to define the cal variable, while you are using getSharedDefaultFolder

Answer 2

Even if you can manually add "Deere John" to your list of calendars, the calendar permission is probably not correct for VBA.
Try this to see if Outlook displays "Cannot display the folder. Microsoft Outlook cannot access the specified folder location."
Sub abcdef_CalDisplay()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim rcpt As Outlook.Recipient
Dim cal As Outlook.folder
Dim appm As Outlook.AppointmentItem
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set rcpt = ns.CreateRecipient("Deere John")
rcpt.Resolve
If Not rcpt.Resolved Then
MsgBox ("Could not resolve recipient")
Return
Else ' <----
Set cal = ns.GetSharedDefaultFolder(rcpt, olFolderCalendar)
cal.Display ' <---
End If
End Sub