Excel Create an Outlook calendar event

Question

Can you run a macro from Excel that can interact with Outlook and create and event on the calendar?

http://excelexperts.com/Creating-appointments-for-outlook-in-VBA — Tim Williams, Dec 04 '12 at 22:46
Can you add that as an answer, so us other helpful souls don't see this as an unanswered question? :) — Chris Rae, Dec 04 '12 at 23:32
Also, how do you add to another calendar that has been shared with you? — KalEl, Jun 26 '14 at 18:33
I can't see why this question is closed for not being focused. Its title defines exactly what is requested and the answers are spot on. — ndemou, Feb 10 '21 at 06:32

score 2 · Answer 1 · answered Jun 08 '17 at 12:59

Slight improvement on other answer

Sub createappt()

Const olFolderCalendar = 9
Const olAppointmentItem = 1 '1 = Appointment

Set objOutlook = CreateObject("Outlook.Application")

'Set objOutlook = GetObject(, "Outlook.Application")  ' outlook already open
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set Items = objNamespace.GetDefaultFolder(olFolderCalendar).Items

Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar).Folders("subfolder")
Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar) ' main calender
Set objapt = objCalendar.Items.Add(olAppointmentItem)
objapt.Subject = "Test" 'Owner
objapt.Start = Date + TimeValue("08:00:00")
objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both)
objapt.End = Date + TimeValue("16:00:00")
objapt.Save
End Sub

score 1 · Answer 2 · answered Feb 10 '15 at 18:45

This will allow you to add an appointment to a shared Calendar in any folder as long as you have the rights to write in it.

Treat Calendar as a Folder

Const olFolderInbox = 6
Const olAppointmentItem = 1 '1 = Appointment

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
'Finds your Inbox
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)

'Gets the parent of your Inbox which gives the Users email
strFolderName = objInbox.Parent
Set objCalendar = objNamespace.Folders("Public folders - " & strFolderName).Folders("SubFolder1").Folders("subfolder of subfolder 1").Folders("Your Calendar")

Set objapt = objCalendar.Items.Add(olAppointmentItem)
objapt.Subject = "Test" 'Owner
objapt.Start = Date + TimeValue("08:00:00")
objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both)
objapt.End= Date + TimeValue("16:00:00")
objapt.Save

0m3r · Answer 3 · 2018-03-07T22:23:32.500

Link from Tim's commment - http://excelexperts.com/Creating-appointments-for-outlook-in-VBA

Sub AddAppointments2()
    ' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")

    ' Start at row 2
    r = 2

    Do Until Trim(Cells(r, 1).Value) = ""
        For Each olapt In olFldr.Items
            If TypeName(myApt) = "AppointmentItem" Then
                If InStr(1, myApt.Subject, "Test and Tag", vbTextCompare) Then
                    myApt.Body = appt.Body & Cells(r, 2)
                    myApt.Save
                Else
                    ' Create the AppointmentItem
                    Set myApt = myOutlook.createitem(1)
                    ' Set the appointment properties
                    myApt.Subject = Cells(r, 1).Value
                    myApt.Location = Cells(r, 2).Value
                    myApt.Start = Cells(r, 4).Value + TimeValue("08:00:00")
                    myApt.Duration = Cells(r, 5).Value
                    ' If Busy Status is not specified, default to 2 (Busy)
                    If Trim(Cells(r, 6).Value) = "" Then
                        myApt.BusyStatus = 2
                    Else
                        myApt.BusyStatus = Cells(r, 6).Value
                    End If
                    If Cells(r, 7).Value > 0 Then
                        myApt.ReminderSet = True
                        myApt.ReminderMinutesBeforeStart = Cells(r, 7).Value
                    Else
                        myApt.ReminderSet = False
                    End If
                    myApt.Body = Cells(r, 12).Value
                    myApt.Save
                    r = r + 1
                End If
            End If
        Next olapt
    Loop
End Sub

Here is other link https://stackoverflow.com/a/49121400/4539709

Excel Create an Outlook calendar event

3 Answers3

Linked