Const olAppointmentItem = 1
Const olFolderCalendar = 9
Dim olkApp, olkSes, olkFld, olkApt
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon olkApp.DefaultProfileName
Set olkFld = olkSes.GetDefaultFolder(olFolderCalendar)
Set olkApt = olkFld.Items.Find("[Subject] = 'Change Backup Tapes' And [Start] = '" & Format(Date & " 3:00 PM", "ddddd h:nn AMPM") & "'")
If TypeName(olkApt) = "Nothing" Then
Set olkApt = olkApp.CreateItem(olAppointmentItem)
With olkApt
'Change the subject as desired'
.Subject = "Change Backup Tapes"
'Change the starting time as desired'
.Start = Date & " 3:00 PM"
'Change the duration as desired (in minutes)'
.Duration = 30
'Change the reminder time as desired'
.ReminderMinutesBeforeStart = 10
.ReminderSet = True
.Save
End With
End If
Set olkApt = Nothing
Set olkFld = Nothing
olkSes.Logoff
Set olkSes = Nothing
Set olkApp = Nothing
|