excelvbaoutlookdirectorypst

How to find the folder reference and add appointment to non default calendar/folder through Excel

I've been building some VBA for a calendar events to be generated through an excel macro. My issue is that I want the event to go to a non default calendar but i'm struggling through my reading here to know how to reference the folder.... and then reference it correctly!

The path for the calendar is "\Res-Cal\Calendar"

The below starting code works for the default calendar

    Sub CreateEventFromExcel()

    Dim olAccount As Outlook.Account
    Dim olMail As Outlook.MailItem
    Dim Provider As Object
    Dim olApp As Outlook.Application
    Dim olEvent As Outlook.AppointmentItem
    Dim StartDate As String
    Dim StartTime As String
    Dim Title As String

    StartDate = ActiveCell.Offset(0, 2)
    StartTime = ActiveCell.Offset(1, 2)
    Title = "Ref: " & Range("F10") & " -- " & ActiveCell.Offset(4, 2) & " -- " & Range("C15") & "/" & Range("L15")

    Set olApp = Outlook.Application
    Set olEvent = olApp.CreateItem(olAppointmentItem)
    Set Provider = Range("L15")

    With olEvent
    .Subject = Title
    .Start = StartDate & " " & Format(StartTime, "h:mm")
    .Duration = 60
    .Categories = "1_Agent Confirmation Sent"
    .Display

    End With

    End Sub

WHAT IT LOOKED LIKE I SHOULD BE DOING

    Sub CreateEventFromExcel()

    Dim olAccount As Outlook.Account
    Dim olMail As Outlook.MailItem
    Dim Provider As Object
    Dim olApp As Outlook.Application
    Dim olEvent As Outlook.AppointmentItem
    Dim StartDate As String
    Dim StartTime As String
    Dim Title As String
    Dim olNameSpace As NameSpace
    Dim olFolder as Object

    StartDate = ActiveCell.Offset(0, 2)
    StartTime = ActiveCell.Offset(1, 2)
    Title = "Ref: " & Range("F10") & " -- " & ActiveCell.Offset(4, 2) & " -- " & Range("C15") & "/" & Range("L15")

    Set olApp = new Outlook.Application
    Set olNameSpace = olApp.Getnamespace("MAPI")
    Set olFolder = olNameSpace.GetFolderFromID("XXXXXXXXXXXXXXXXX").Items.Add(olAppointmentItem)

    Set olEvent = olApp.CreateItem(olAppointmentItem)
    Set Provider = Range("L15")

    With olFolder
    .Subject = Title
    .Start = StartDate & " " & Format(StartTime, "h:mm")
    .Duration = 60
    .Categories = "1_Agent Confirmation Sent"
    .Display

    End With
    End Sub

My first question is how do I find the xxxxxxx? This is a different PST in outlook "Res-Cal"

enter image description here

I did try other posts for finding the missing string here but they did not return anything but instead just displayed my outlook folder structure in totality.

I thought I was to use folder # so did randomly try some numbers from 1-20 but none worked so I'm down the wrong path.

Any help would be much appreciated as creating in the default calendar is not going to cut it for what I need.

Thanks!

Updated Code below

Sub EMAILQUERY()

Dim olAccount As Outlook.Account
Dim olMail As Outlook.MailItem
Dim Provider As Object
Dim olApp As Outlook.Application
Dim olEvent As Outlook.AppointmentItem
Dim StartDate As String
Dim StartTime As String
Dim Title As String
Dim olNameSpace As Namespace
Dim olFolder As Object
Dim MAPIFolder As Object

StartDate = ActiveCell.Offset(0, 2)
StartTime = ActiveCell.Offset(1, 2)
Title = "Ref: " & Range("F10") & " -- " & ActiveCell.Offset(4, 2) & " -- " & Range("C15") & "/" & Range("L15")


Set olApp = New Outlook.Application

Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.Stores("Res-Cal").Folders("Calendar")


Set olEvent = MAPIFolder.Items.Add()

Set Provider = Range("L15")



With olFolder
    .Subject = Title
    .Start = StartDate & " " & Format(StartTime, "h:mm")
    .Duration = 60
    .Categories = "1_Agent Confirmation Sent"
    .Display


End With

End Sub

Latest updated code

Sub EMAILQUERY()

Dim olAccount As Outlook.Account
Dim olMail As Outlook.MailItem
Dim Provider As Object
Dim olApp As Outlook.Application
Dim olEvent As Outlook.AppointmentItem
Dim StartDate As String
Dim StartTime As String
Dim Title As String
Dim olNameSpace As Namespace
Dim olFolder As Outlook.folder


StartDate = ActiveCell.Offset(0, 2)
StartTime = ActiveCell.Offset(1, 2)
Title = "Ref: " & Range("F10") & " -- " & ActiveCell.Offset(4, 2) & " -- " & Range("C15") & "/" & Range("L15")


Set olApp = New Outlook.Application

Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.Stores("Res-Cal").Folders("Calendar")

olNameSpace.GetFolderFromID("XXXXXXXX").Items.Add(olAppointmentItem)

Set olEvent = olFolder.Items.Add()

Set Provider = Range("L15")



With olFolder
    .Subject = Title
    .Start = StartDate & " " & Format(StartTime, "h:mm")
    .Duration = 60
    .Categories = "1_Agent Confirmation Sent"
    .Display


End With

End Sub

Updated

Sub EMAILQUERY()

Dim olAccount As Outlook.Account
Dim olMail As Outlook.MailItem
Dim Provider As Object
Dim olApp As Outlook.Application
Dim olEvent As Outlook.AppointmentItem
Dim StartDate As String
Dim StartTime As String
Dim Title As String
Dim olNameSpace As Namespace
Dim olFolder As Outlook.folder


StartDate = ActiveCell.Offset(0, 2)
StartTime = ActiveCell.Offset(1, 2)
Title = "Ref: " & Range("F10") & " -- " & ActiveCell.Offset(4, 2) & " -- " & Range("C15") & "/" & Range("L15")

Set olApp = New Outlook.Application

Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.Stores("Res-Cal").GetRootFolder.Folders("Calendar")

Set olEvent = olFolder.Items.Add()

Set Provider = Range("L15")


With olFolder
    .Subject = Title
    .Start = StartDate & " " & Format(StartTime, "h:mm")
    .Duration = 60
    .Categories = "1_Agent Confirmation Sent"
    .Display


End With

    End Sub
Solution

  • For the folder name option where folderpath is "\Res-Cal\Calendar"
    rather than the .GetFolderFromID option (Debug.Print ActiveExplorer.CurrentFolder.EntryID).

    With a folder not under the mailbox.

    Set olFolder = olNameSpace.Stores("Res-Cal").GetRootFolder.Folders("Calendar")

    rather than default folder code

    Set folder = olNameSpace.Stores("someone@somewhere.com").GetDefaultFolder(olFolderCalendar)

    Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Sub EMAILQUERY()

' Early binding requires reference to Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim olEvent As Outlook.AppointmentItem

Dim Title As String
Dim olNameSpace As Namespace
Dim olFolder As Outlook.Folder

Title = "Title"

Set olApp = New Outlook.Application
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.Stores("Res-Cal").GetRootFolder.Folders("Calendar")

Set olEvent = olFolder.Items.Add()

With olEvent
    .Subject = Title
    .Display
End With

End Sub