Create a Outlook Calendar event from Excel in a named calendar that is not the default one-CodePudding

I created the below code to create an Outlook calendar event with specific info from cells.

I need to change it from default calendar to a different named calendar "Test".

This is many edits in so some of the code may not be used but if it didn't break it I haven't removed it. e.g. this used to send an email to recipients.

Sub CreateAppointmentBuildVhub()
    ' Outlook application object.
    
    'FOR CALENDAR ONLY
    Dim objOL       As Object
    ' Appointment item object.
    Dim objItem     As Object
    ' TimeZone object that represents "Eastern Standard Time" in Outlook.
    Dim tzEastern   As Object
    'FOR CALENDAR AND EMAIL
    Dim AWorksheet As Worksheet
    'FOR EMAIL ONLY
    Dim Sendrng As Range
    Dim Rng As Range
    
       
    'FOR CALENDAR ENTRY
    Set objOL = GetObject(, "Outlook.Application")
    Set tzEastern = objOL.TimeZones.Item("Eastern Standard Time")
    Set objItem = objOL.CreateItem(1)
    Set AWorksheet = ActiveSheet
    'FOR EMAIL SEND
       
    
    With objItem
        .Start = Worksheets("Info").Range("C14").Text
        .StartTimeZone = tzEastern
        
        .Body = Worksheets("Info").Range("C2") & Chr(10) & Worksheets("Info").Range("C3") & Chr(10) & Worksheets("Info").Range("C4") & Chr(10) & Chr(10) & Worksheets("Info").Range("E2") & Chr(10) & Worksheets("Info").Range("E3")
        .Location = Worksheets("Info").Range("C3")
        .AllDayEvent = True
        .Subject = Worksheets("Info").Range("B14")
        .ReminderMinutesBeforeStart = 15
        .ReminderSet = False
        .Display
    End With
    Set objItem = Nothing
    Set objOL = Nothing
    Set tzEastern = Nothing
    

   'Activate the sheet that was active before you run the macro
    AWorksheet.Select
    
    'STOPS SCRIPT IF ERRORS
   

End Sub

CodePudding user response：

This did what I needed.

Sub CreateAppointmentBuildVhub()
    ' Outlook application object.
    
    'FOR CALENDAR ONLY
    Dim objOL       As Object
    ' Appointment item object.
    Dim objItem     As Object
    ' TimeZone object that represents "Eastern Standard Time" in Outlook.
    Dim tzEastern   As Object
    'FOR CALENDAR AND EMAIL
    Dim AWorksheet As Worksheet
    'FOR EMAIL ONLY
    Dim Sendrng As Range
    Dim Rng As Range
    
       
    'FOR CALENDAR ENTRY
    Set objOL = GetObject(, "Outlook.Application")
    Set tzEastern = objOL.TimeZones.Item("Eastern Standard Time")
    
    Set AWorksheet = ActiveSheet
    'FOR EMAIL SEND
    Set Folder = objOL.Session.GetDefaultFolder(olFolderCalendar).Folders("Test")
    Set objItem = Folder.Items.Add
    
    With objItem
        .Start = Worksheets("Info").Range("C14").Text
        .StartTimeZone = tzEastern
        
        .Body = Worksheets("Info").Range("C2") & Chr(10) & Worksheets("Info").Range("C3") & Chr(10) & Worksheets("Info").Range("C4") & Chr(10) & Chr(10) & Worksheets("Info").Range("E2") & Chr(10) & Worksheets("Info").Range("E3")
        .Location = Worksheets("Info").Range("C3")
        .AllDayEvent = True
        .Subject = Worksheets("Info").Range("B14")
        .ReminderMinutesBeforeStart = 15
        .ReminderSet = False
        .Display
    End With
    Set objItem = Nothing
    Set objOL = Nothing
    Set tzEastern = Nothing
    

   'Activate the sheet that was active before you run the macro
    AWorksheet.Select
    
    'STOPS SCRIPT IF ERRORS
   

End Sub

CodePudding user response：

Instead of calling Application.CreateItem(olAppontment), you need to call MAPIFolder.Items.Add on the folder where the appointment needs to be created.

Assuming "Test" is a subfolder of the default Calendar folder:

set folder = objOL.Session.GetDefaultFolder(olFolderCalendar).Folders("Test")
Set objItem = folder.Items.Add