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?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

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
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
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

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
Rgonzo1971Commented:
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
melinhomesAuthor Commented:
Thank you very, very much! It has worked a treat. Much appreciated!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.