Create Outlook calendar event with Visual Basic VB for selected chosen calendar, when having multiple accounts - vba

Question

I want to create Visual Basic scrip to create calendar event/invitation.
Script is working perfectly, when only one account is registered in outlook, and event is created OK for this single calendar (account).
PROBLEM:
I have two accounts registered in my outlook. One of the accounts is company-managed (let's call it FIRST). I have also manually created account (let's call it SECOND).
The problem is when I want to create event "on behalf" of SECOND calendar registered manually. I've already set SECOND account as primary account in outlook with:
Outlook->File->Account Settings->Account Setting...->Email Tab->Set as default.
When I'm using (almost) identical code as below to create Outlook email object, script is working perfectly fine, and field "Sender" in the message is populated with correct SECOND account name.
Picture: Email outlook object created, with SENDER populated with correct SECOND account
I've tried to set property: objAppointmentItem.SendUsingAccount = myAccount , with the SECOND account, but then Sender field is left empty, and you can't select account from combo. When I'm sending it it ANYWAY, then it is send to correct recipients, but is NOT send to my SECOND calendar (desired), and invitation/event is visible in my FIRST calendar, which I DON'T want to use anymore.
Picture: Outlook event object with FROM field empty, no selection possible
When I'm NOT setting property: objAppointmentItem.SendUsingAccount = myAccount , event object is created, but is assigned with FIRST account, despite SECOND is set as default.
Picture: Event created with wrong sender, and NO SELECTION possible for SECOND account
When I create invitation with double-click on calendar itself (SECOND account calendar), then invitation is created with correct SECOND account populated in SENDER field, (still no option to select other account - but no need, as is correct :) )
Sub OutOfOfficeEvent()
Dim oAccount As Outlook.Account
Dim myAccount As Outlook.Account
'try to find PERSONAL account. If failed, then send with last avail on the list Application.Session.Accounts
For Each oAccount In Application.Session.Accounts
Set myAccount = oAccount
If InStr(UCase(oAccount.DisplayName), "PERSONAL.COM") Then
Exit For
End If
Next
Dim objOutlookApplication As Outlook.Application
Dim objAppointmentItem As Outlook.AppointmentItem
Dim objRecipient As Recipient
Dim objRecipients As Recipients
Set objOutlookApplication = CreateObject("Outlook.Application")
Set objAppointmentItem = objOutlookApplication.CreateItem(olAppointmentItem)
'###############################################
'####### NOT working for event/invitation
'####### Working OK for email object creation
'###############################################
objAppointmentItem.SendUsingAccount = myAccount
'###############################################
objAppointmentItem.Display
Set objRecipients = objAppointmentItem.Recipients
Set objRecipient = objAppointmentItem.Recipients.Add("somebody1#PERSONAL.COM")
Set objRecipient = objAppointmentItem.Recipients.Add("somebody2#PERSONAL.COM")
objRecipient.Type = olRequired
For Each objRecipient In objAppointmentItem.Recipients
objRecipient.Resolve
Next
Dim DateStart As Date
Dim DateEnd As Date
DateStart = DateTime.DateAdd("d", 0, DateTime.DateAdd("h", 1, DateTime.DateAdd("s", -Second(Now()), DateTime.DateAdd("n", -Minute(Now()), Now()))))
DateEnd = DateTime.DateAdd("h", 1, DateStart)
With objAppointmentItem
.MeetingStatus = olMeeting
.Subject = "[OOO] " & strUser
.Start = DateStart
.End = DateEnd
.AllDayEvent = False
.ReminderSet = False
.BusyStatus = olFree
.ResponseRequested = False
.Location = ""
.Body = "Some body content"
End With
objAppointmentItem.Display
Set objOutlookApplication = Nothing
End Sub

Answer 1

There are several ways of creating new items in Outlook. See How To: Create a new Outlook Appointment item for more information.
If you have two accounts configured in Outlook you need to get the right calendar folder and then add a new calendar entry there. To get this done you can use the GetDefaultFolder method of the Store class which returns a Folder object that represents the default folder in the store and that is of the type specified by the FolderType argument. This method is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile. So, you may get the right store and add the new calendar entry.
The NameSpace.Stores property returns a Stores collection object that represents all the Store objects in the current profile.
Sub EnumerateFoldersInStores()
Dim colStores As Outlook.Stores
Dim oStore As Outlook.Store
Dim oCalendar As Outlook.Folder
On Error Resume Next
Set colStores = Application.Session.Stores
For Each oStore In colStores
Set oCalendar = oStore.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)
Debug.Print (oCalendar.FolderPath)
Next
End Sub

Answer 2

I had the same problem and with above suggestion and some more Google, I found the total solution:
Dim myAI As Outlook.AppointmentItem
myAI = Nothing
Dim oStore As Outlook.Store
For Each oStore In colStores
Dim oCalendar As Outlook.Folder
Set oCalendar = oStore.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)
If LCase(oCalendar.Description) = "<accountname>" Then
Set myAI = oCalendar.Items.Add(Outlook.OlItemType.olAppointmentItem)
Exit For
End If
Next