Place a calendar appointment in Outlook using Access VBA

I want to be able to enter details on an Access form, which will form the basis of an Outlook calendar appointment. Not only in my calendar but also another team calendar, which i wanted to hard code. I have done the code below:

Private Sub Command127_Click()
' Save record.
DoCmd.RunCommand acCmdSaveRecord

'add to Outlook.
Dim olApp As Object ' Outlook.Application
Dim olappt As Object ' olAppointmentItem
Set olApp = CreateObject("outlook.application")
Set olappt = olApp.CreateItem(olAppointmentItem)

Set olappt = olApp.CreateItem(1)
With olappt
.Start = Me!ContractStartDate & " " & Me!ContractStartTime1
.End = Me!ContractStartDate & " " & Me!ContractStartTime2
.Subject = Me!CaseTitle
.location = "Contract Start Date"
.Body = ""
.reminderminutesbeforestart = 15
.reminderset = True
.MeetingStatus = olMeeting
.recipients.Add ("123@abc.co.uk")
.recipients.resolveall
.Save
End With
Set olApp = Nothing
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
End Sub

However, it shows in my calendar fine, I check the appointment, the team calendar name has been resolved fine, but it doesn't appear in there calendar. Is there some code I can add to achieve this?

Any help would be greatly appreciated.

Thanks
Gareth
melinhomesAsked:
Who is Participating?
 
Rgonzo1971Connect With a Mentor Commented:
then try  you have to change line 10 with the shared mailbox)
Private Sub Command127_Click()
' Save record.
DoCmd.RunCommand acCmdSaveRecord

'add to Outlook.
Dim olApp As Object ' Outlook.Application
Dim olappt As Object ' olAppointmentItem
Set olApp = CreateObject("outlook.application")
Set objNamespace = olApp.GetNamespace("MAPI")
Set objRecip = objNamespace.CreateRecipient("YourSharedEmailAddress") 'change here
Set objFolder = objNamespace.GetSharedDefaultFolder(objRecip, 9) 'olFolderCalendar
if objFolder is nothing then
  Debug.Print "This person does not have access to the shared folder"
else
Set olappt = olApp.CreateItem(1)
With olappt
.Start = Me!ContractStartDate & " " & Me!ContractStartTime1
.End = Me!ContractStartDate & " " & Me!ContractStartTime2
.Subject = Me!CaseTitle
.location = "Contract Start Date"
.Body = ""
.reminderminutesbeforestart = 15
.reminderset = True
.MeetingStatus = olMeeting
.recipients.Add ("123@abc.co.uk")
.recipients.resolveall
.Save
Set copyAppt = .Copy
Set movedAppt = copyAppt.Move(objFolder)
End With
end if
Set olApp = Nothing
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
End Sub

Open in new window

1
 
Rgonzo1971Commented:
Hi,

Have you tried to send (not only saving it) the appointment?

Regards
0
 
melinhomesAuthor Commented:
I have tried adding
.send
I get the prompt saying to allow, but the appointment entry still doesn't appear in the team calendar, even though the person logged in has publishing editor permissions to the calendar in question.
0
Cloud Class® Course: CompTIA Healthcare IT Tech

This course will help prep you to earn the CompTIA Healthcare IT Technician certification showing that you have the knowledge and skills needed to succeed in installing, managing, and troubleshooting IT systems in medical and clinical settings.

 
Rgonzo1971Commented:
Could you try this
Private Sub Command127_Click()
' Save record.
DoCmd.RunCommand acCmdSaveRecord

'add to Outlook.
Dim olApp As Object ' Outlook.Application
Dim olappt As Object ' olAppointmentItem
Set olApp = CreateObject("outlook.application")
Set objNamespace = olApp.GetNamespace("MAPI")
Set objRecip = objNamespace.CreateRecipient("YourEmailAddress") 'change here
Set objFolder = objNamespace.GetSharedDefaultFolder(objRecip, olFolderCalendar)
if objFolder is nothing then
  Debug.Print "This person does not have access to the shared folder"
else
Set olappt = olApp.CreateItem(1)
With olappt
.Start = Me!ContractStartDate & " " & Me!ContractStartTime1
.End = Me!ContractStartDate & " " & Me!ContractStartTime2
.Subject = Me!CaseTitle
.location = "Contract Start Date"
.Body = ""
.reminderminutesbeforestart = 15
.reminderset = True
.MeetingStatus = olMeeting
.recipients.Add ("123@abc.co.uk")
.recipients.resolveall
.Save
Set copyAppt = .Copy
Set movedAppt = copyAppt.Move(objFolder)
end if
End With
Set olApp = Nothing
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
End Sub

Open in new window

EDITED
0
 
melinhomesAuthor Commented:
Thank you, I have a compile error, End If without block If?

I tried amending that code (put the end if after the end with) then and had an invalid procedure call or argument on this line:

Set objFolder = objNamespace.GetSharedDefaultFolder(objRecip, olFolderCalendar)

Apologies my knowledge of VB isn't great, i've only managed to put this code together with what i have found on the net.
0
 
melinhomesAuthor Commented:
It is resolving a user (procurement team) from Exchange. I just put the abc@123.co.uk as work dont like me posting e-mail addresses. Thank you again.
0
 
melinhomesAuthor Commented:
Thank you very, very much! It has worked a treat. Much appreciated!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.