This code creates an appointment, and could also update an existing appointment
Sample of use :
Call Outlook_AddUpdate_Appointment("Test-Now", Date, "Test Appointment", "This is the Body", Now, Now, sLabel:="The label", sLocation:="At Home")
If you want to update it, just use the same ID
Call Outlook_AddUpdate_Appointment("Test-Now", Date, "Updated Appointment", "This is the Body", Now, Now, sLabel:="The label", sLocation:="At Home")
Just add this module
Sample of use :
Call Outlook_AddUpdate_Appointment("Test-Now", Date, "Test Appointment", "This is the Body", Now, Now, sLabel:="The label", sLocation:="At Home")
If you want to update it, just use the same ID
Call Outlook_AddUpdate_Appointment("Test-Now", Date, "Updated Appointment", "This is the Body", Now, Now, sLabel:="The label", sLocation:="At Home")
Just add this module
Code:
Option Explicit
Public oOpenOutlook As Object 'Outlook.APPLICATION ' Object '
Public oOpenCalendarFolder As Object 'Outlook.Folder ' Object '
Public Const olFolderInbox = 6
Public Const olFolderCalendar = 9
Public Const olFolderContacts = 10
Public Const olDistributionListItem = 7
Private Const olAppointmentItem = 1
Private Const olContactItem = 2
Private Const olText = 1
Public Const IMPORTANCE_LOW = 0
Public Const IMPORTANCE_NORMAL = 1
Public Const IMPORTANCE_HIGH = 2
Public Sub Outlook_AddUpdate_Appointment(sID As String, sDate As String, sSubject As String, sBody As String, _
Optional sStartTime As String = vbNullString, Optional sEndTime As String = vbNullString, _
Optional bAllDayEvent As Boolean = False, Optional bBusyStatus As Boolean = False, _
Optional sLabel As String = vbNullString, Optional sLocation As String = vbNullString, _
Optional bMeetingFlag As Boolean = False, Optional bPrivateFlag As Boolean = False, Optional sCustomProperties As String = vbNullString)
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 11/16/2005
' * Time : 19:33
' * Module Name : Outlook_Module
' * Module Filename : Outlook.bas
' * Procedure Name : Outlook_AddUpdate_Appointment
' * Purpose :
' * Parameters :
' * sID As String
' * sDate As String
' * sSubject As String
' * sBody As String
' * Optional sStartTime As String = vbNullString
' * Optional sEndTime As String = vbNullString
' * Optional bAllDayEvent As Boolean = False
' * Optional bBusyStatus As Boolean = False
' * Optional sLabel As String = vbNullString
' * Optional sLocation As String = vbNullString
' * Optional bMeetingFlag As Boolean = False
' * Optional bPrivateFlag As Boolean = False
' * Optional sCustomProperties As String = vbNullString
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_Outlook_AddUpdate_Appointment
Dim oCalendarItems As Object 'Outlook.Items '
Dim oAppointment As Object 'Outlook.AppointmentItem '
If oOpenOutlook Is Nothing Then Set oOpenOutlook = CreateObject("Outlook.Application")
If oOpenCalendarFolder Is Nothing Then Set oOpenCalendarFolder = oOpenOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
' *** Using BillingInformation to save a personnal identifier in order to allow future update/delete
Set oCalendarItems = oOpenCalendarFolder.Items.Restrict("[BillingInformation] " & "= 'MyApp:" & sID & "'")
If oCalendarItems.Count = 0 Then
Set oAppointment = oOpenOutlook.CreateItem(olAppointmentItem)
Else
Set oAppointment = oCalendarItems.Item(1)
End If
With oAppointment
.Start = sStartTime
.End = IIf(LenB(sEndTime) = 0, sStartTime, sEndTime)
.Subject = sSubject
If LenB(sCustomProperties) > 0 Then
.body = sBody & vbCrLf & sCustomProperties
Else
.body = sBody
End If
.AllDayEvent = bAllDayEvent
.BusyStatus = IIf(bBusyStatus, 2, 0)
.Location = sLocation
If .UserProperties.Count = 0 Then
.UserProperties.Add "CustomProperties", olText
.UserProperties.Item(1).Value = sCustomProperties
Else
.UserProperties.Item("CustomProperties").Value = sCustomProperties
End If
.ReminderSet = False
If LenB(.BillingInformation) = 0 Then .BillingInformation = "MyApp:" & sID
.Save
End With
EXIT_Outlook_AddUpdate_Appointment:
Set oCalendarItems = Nothing
Set oAppointment = Nothing
Exit Sub
' #VBIDEUtilsERROR#
ERROR_Outlook_AddUpdate_Appointment:
Resume EXIT_Outlook_AddUpdate_Appointment
Resume
End Sub