Sub SetAppointment()
Dim olApp As Outlook.Application
Dim olApt As AppointmentItem
Set olApp = New Outlook.Application
Set olApt = olApp.CreateItem(olAppointmentItem)
With olApt
.Start = DateSerial(2003, 7, 12) + TimeSerial(10, 0, 0)
.End = DateSerial(2003, 7, 12) + TimeSerial(18, 0, 0)
.Subject = Range("A2")
.Location = Range("B2")
.Body = Range("C2")
.Categories = "Business"
.Sensitivity = olPrivate
.BusyStatus = olFree
.ReminderMinutesBeforeStart = 240
.ReminderSet = True
.Save
End With
Set olApt = Nothing
Set olApp = Nothing
End Sub