Public Sub ToOutLookCalendar(ByVal Subject As String, ByVal EventStart As Date, ByVal EventEnd As Date)
On Error GoTo errTrap
Dim oApp As New Outlook.Application
Dim oCalendar As Outlook.MAPIFolder
Dim oNameSpace As Outlook.NameSpace
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oCalendar = oNameSpace.GetDefaultFolder(olFolderCalendar)
With oCalendar.Items.Add(olAppointmentItem)
.AllDayEvent = True
.Subject = Subject
.Start = EventStart
.End = EventEnd
.ReminderSet = False
.Save
End With
Err_Exit:
Set oCalendar = Nothing
Set oNameSpace = Nothing
Set oApp = Nothing
Exit Sub
errTrap:
'Code to handle errors goes here
Resume Err_Exit
End Sub