Add appointment to a non-default calendar - excel

Question

I know there's additional stuff in the Declarations, it's for other macros I've written.
I've several calendars. I've a spreadsheet where I paste information about a site, and I've buttons that generate appointments and emails.
I've code to set an appointment, however it goes to my main calendar. I'm trying to get the appointment onto my other calendars. I've read about MAPI functions, but can't get it to work. The location is \myemail#me.com\Calendar. Name of the calendar is SVN Calendar.
Dim olApp As Outlook.Application9
Dim olEmail As Outlook.MailItem
Dim olCal As Outlook.AppointmentItem
Dim olFolder As Outlook.Folder
Dim RequiredAttendee, OptionalAttendee, ResourceAttendee As Outlook.Recipient
Dim rtf() As Byte
Dim rngTo As Range
Dim rngCC As Range
Dim rngSUB As Range
Dim rngCALloc As Range
Dim rngCALstart As Range
Dim rngCALend As Range
Dim rngBody As Range
Dim myItem As Object
Sub newTestCreateCalendarUSA1()
'Testing calendar to other calendar than main.
' i.e. SVN Calendar. can't identify the actual calendar.
Set olApp = New Outlook.Application
Set m = olApp.CreateItem(olMailItem)
Set appt = olApp.CreateItem(olAppointmentItem)
With ActiveSheet
Set rngCC = .Range("I34")
Set rngCALloc = .Range("I5")
Set rngCALstart = .Range("I11")
Set rngCALend = .Range("I12")
Set rngSUB = .Range("I33")
Set rngSite = .Range("C2")
Set rngLoc = .Range("C4")
Set rngTYPE = .Range("B23")
Set rngGON = .Range("C23")
Set rngPurpose = .Range("C21")
Set rngGoals = .Range("C22")
Set rngDate = .Range("I1")
Set rngDateStart = .Range("I8")
Set rngDateEnd = .Range("I9")
Set rngTime = .Range("I10")
Set rngCAS = .Range("C26")
End With
MsgBox "Ensure all attendees are correct prior to sending invite."
appt.MeetingStatus = olMeeting
appt.RequiredAttendees = rngCC.Value
appt.Subject = rngSUB.Value
appt.Location = rngCALloc.Value
appt.Start = rngCALstart.Value
appt.End = rngCALend.Value
appt.AllDayEvent = True
m.BodyFormat = olFormatHTML
m.HTMLBody = Range("I31").Value
m.GetInspector().WordEditor.Range.FormattedText.Copy
appt.GetInspector().WordEditor.Range.FormattedText.Paste
appt.Display
m.Close False
End Sub
Edit: Thanks for directing me to follow the folder tree. I tried understanding the GetNameSpace thing, but couldn't get it to work.
I did find a different code and got it to make an appointment on the correct calendar.
Sub SVN_Calendar_Invite()
'trial run of SVN Calendar with other code
Dim oApp As Object
Dim oNameSpace As Namespace
Dim oFolder As Object
Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("0000000098F32312526B334EAEC97D94705E33FB0100C964D8D325E3554DA24A72FB876E3F600001912394000000")
With ActiveSheet
Set rngCC = .Range("I34")
Set rngCALloc = .Range("I5")
Set rngCALstart = .Range("I11")
Set rngCALend = .Range("I12")
Set rngSUB = .Range("I33")
Set rngSite = .Range("C2")
Set rngLoc = .Range("C4")
Set rngTYPE = .Range("B23")
Set rngGON = .Range("C23")
Set rngPurpose = .Range("C21")
Set rngGoals = .Range("C22")
Set rngDate = .Range("I1")
Set rngDateStart = .Range("I8")
Set rngDateEnd = .Range("I9")
Set rngTime = .Range("I10")
Set rngCAS = .Range("C26")
End With
With oFolder
Set olApt = oApp.CreateItem(olAppointmentItem)
With olApt
.AllDayEvent = True
.RequiredAttendees = rngCC.Value
.Start = rngDateStart.Value
.End = rngDateEnd.Value
.Subject = rngSUB.Value
.Location = rngLoc.Value
.Body = "The body of your appointment note"
.BusyStatus = olFree
.Save
.Move oFolder
End With
Set olNS = Nothing
Set olApp = Nothing
Set olApt = Nothing
End With
End Sub
I've these problems now.
1- if I use .Display to bring up the calendar item to review it, it doesn't display.
2- even though it's an all day event, and the cells are 3 days apart, it subtracts the end date by 1 day.
3- I have to manually invite the attendees, which defeats the purpose of doing this invite.

Answer 1

ok so im about two years late. found this thread while i was facing the same problem. manage to solve with some trial and error so, this works for me.
so you might give it a try for future pple who are googling for the same ans...
a lil more info is i did not set reference to Outlook under tools cos i have many user files.
'start
'break down here retype cos stackoverflow format xxx
Sub Add_Appt_to_Main_Sub_Calendar()
Dim BOOK2 As Workbook
Workbooks.Open Filename:= _
"Name of your file.csv"
'csv is readable by outlook but not excel, u need to change the file type first
'start pulling data from your csv file here
'if you are not setting reference to outlook under tools, please define all your outlook names as Object
Dim olAppts As Object
Dim Calfolder As Object
'this to define the main calendar folder
Dim Subfolder As Object
'this to define the sub calendar folder
Set olApp = CreateObject("Outlook.Application")
Set olNamespace = olApp.GetNamespace("MAPI")
Dim filter As Variant
'cos we dont want to keep import duplicate appt into outlook calendar so we need to create and define a filter
Dim olfolder As Object
'the folder picker by user
Dim strolFolder As String
' we want to get the name of the folder picker by user
Set olfolder = olApp.GetNamespace("MAPI").Pickfolder
'olfolder.Display
'how to find the name of the folder selected
On Error Resume Next
If olfolder = "" Then
MsgBox "No calendar selected."
Workbooks("Name of your file.csv").Close savechanges:=True
'close the csv file if no calendar selected by user
Exit Sub
Else
strolFolder = olfolder
'name of the file pick by user
Set Calfolder = olNamespace.GetDefaultFolder(9)
'defaultfolder(9) is the main calendar by default tagged to user outlook acc
strCalfolder = Calfolder
'name of the sub folder
MsgBox strolFolder
MsgBox strCalfolder
MsgBox (olfolder.folderpath)
MsgBox (Calfolder.folderpath)
'keep for debugging
If olfolder.folderpath <> Calfolder.folderpath Then
'this is the line that add appointment into sub calendar
Set olAppts = olNamespace.GetDefaultFolder(9).Folders(strolFolder)
'eg. Set olAppts = olNamespace.GetDefaultFolder(9).Folders("name of subfolder")
'this is the main folder
Set Calfolder = olNamespace.GetDefaultFolder(9)
'MsgBox Calfolder
'this is the sub folder i want to add in
Set Subfolder = Calfolder.Folders(strolFolder)
'MsgBox Subfolder
'add appt to subfolder
Set olAppt = Subfolder.items.Add
'MsgBox (olfolder.EntryID)
'MsgBox (olfolder)
'MsgBox (olfolder.FolderPath)
'keep for debugging
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
'filter by subject, start date and location
'filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
'filter = "[Subject] = '" & Replace(Cells(r, 2).Value, "'", "''") & "' and [Start] = '" & Format(Cells(r, 7).Value, "dddd Hn:Hn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
'On Error Resume Next 'enable error-handling machine
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
'Set olAppt = olAppts.items.Find(filter)
'currently this does a check in your main calendar
'if existing appointment based on subject, start date and location is not found, add appointment
' i need to do a search in the subcalendar instead of main calendar
Set olAppt = olAppts.items.Find(filter)
If TypeName(olAppt) = "Nothing" Then
Set myAppt = Subfolder.items.Add
'Set myAppt = olApp.CreateItem(1)
'if using main use create, if use subfolder add
myAppt.Subject = Cells(r, 2).Value
myAppt.Location = Cells(r, 8).Value
myAppt.Start = Cells(r, 7).Value
myAppt.Categories = Cells(r, 3).Value
myAppt.Duration = 120
myAppt.BusyStatus = 2
myAppt.ReminderSet = True
myAppt.Body = Cells(r, 11).Value
myAppt.Save
End If
r = r + 1
Loop
MsgBox "TCU added to sub calendar."
'if picked folder is sub calendar
Else
Set olApp = CreateObject("Outlook.Application")
strCalfolder = olNamespace.GetDefaultFolder(9)
Set olNamespace = olApp.GetNamespace("MAPI")
Set olAppts = olNamespace.GetDefaultFolder(9)
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
'filter by subject, start date and location
'filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
'filter = "[Subject] = '" & Replace(Cells(r, 2).Value, "'", "''") & "' and [Start] = '" & Format(Cells(r, 7).Value, "dddd Hn:Hn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
On Error Resume Next 'enable error-handling machine
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
Set olAppt = olAppts.items.Find(filter)
'if existing appointment not found, add appointment
If TypeName(olAppt) = "Nothing" Then
Set myAppt = olApp.CreateItem(1)
myAppt.Subject = Cells(r, 2).Value
myAppt.Location = Cells(r, 8).Value
myAppt.Start = Cells(r, 7).Value
myAppt.Categories = Cells(r, 3).Value
myAppt.Duration = 120
myAppt.BusyStatus = 2
myAppt.ReminderSet = True
myAppt.Body = Cells(r, 11).Value
myAppt.Save
End If
r = r + 1
Loop
MsgBox "TCU added to main calendar."
End If
End If
'end add appt
'close ur csv file
Workbooks("Name of your file.csv").Close savechanges:=True
End Sub