How to Add An Appointment In Another Calendar Folder Through Access VBA

[ElCid_boss]

I'm designing the code below so I can automatically send appointments invitations through my Access file to Outlook Calendar.

The problem is that I don't want to fill my default email account with tons of appointments. I would rather choose another personal calendar or shared calendar and send the appointment through that ones.


In the code below I try to send using another email account "viagens@company.com" but the Appointment is always added to my default account.


I think I spent more than 5 hours around this but could not figure a solution out. Please HELP!


Private Sub Command10_Click()


Dim obj0App As Object
Dim objAppt As Object
Dim EmailAddy As Object
Dim ASMail As Object
Dim QualificationEmail As Object
Dim STdate As Object
Dim StTime As Object
Dim Edate As Object
Dim Location As Object
Dim test As Object




Set obj0App = CreateObject("outlook.Application")
Set objAppt = obj0App.CreateItem(1) 'olAppointmentItem
With objAppt

.SendUsingAccount = "viagens@company.com"
.RequiredAttendees = "test@company.com; francisco@company.com"
'.OptionalAttendees = Forms("Copy Of frm_task").ASMail.Value
.Subject = "Training booked for " & " " & Forms("Copy Of frm_task").Contato.Value
.Importance = 2 'high
.Start = Forms("Copy Of frm_task").ETS.Value
.End = Forms("Copy Of frm_task").ETA.Value
.Location = "Multilem"
.ReminderMinutesBeforeStart = 60 'reminder set for two weeks before the event
'.Body = "Training for" & " " & Forms("Copy Of frm_task").QualificationEmail.Value & "." & vbNewLine & "Any changes to this arrangement will be emailed to you. You will recieve any confirmation for bookings nearer the time."
.MeetingStatus = 1
.ResponseRequested = False
.Display
.Send
MsgBox "Appointment sent"
End With


End Sub

Continue reading...