asked on

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

Rgonzo1971

Hi,

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

Regards

melinhomes

ASKER

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.

Rgonzo1971

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

melinhomes

ASKER

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.

melinhomes

ASKER

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.

ASKER CERTIFIED SOLUTION

Rgonzo1971

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

melinhomes

ASKER

Thank you very, very much! It has worked a treat. Much appreciated!