Sub CreateCalendarSchedule_Click()
'Declare Variables
Dim ol As Object
Dim oItem As Object
Dim StartDate As Date
Dim StartTime As String
Dim EndDate As Date
Dim EndTime As String
Dim TimingofWork As String
Dim BuildingofWork As String
Dim Title As String
Dim DetailedDescriptionofWorks As String
Dim ImplementationPlan As String
Dim Whatmonitoring As String
Dim Backoutplan As String
Dim TestPlan As String
Dim PostImplementationVerification As String
Dim ImpacttoSytemOutputsandUsers As String
Dim Otherifapplicable As String
Dim CRNumber As String
Dim makeReminder As String
'Check Outlook is Open and if not then open
On Error Resume Next
Set ol = GetObject(, "Outlook.Application")
On Error GoTo 0
If ol Is Nothing Then
Set ol = CreateObject("Outlook.Application")
End If
'Capture Data From Excel
StartDate = [C11]
StartTime = [E11]
EndDate = [G11]
EndTime = [I11]
TimingofWork = [K11]
BuildingofWork = [C13]
Title = [I13]
DetailedDescriptionofWorks = [C15]
ImplementationPlan = [F17]
Whatmonitoring = [F19]
Backoutplan = [F21]
TestPlan = [F23]
PostImplementationVerification = [F25]
ImpacttoSytemOutputsandUsers = [C27]
Otherifapplicable = [C29]
CRNumber = [J31]
'Create Appointment Item
[highlight ]Set oItem = ol.CreateItem(olAppointmentItem)[/highlight]
'Set Start Date
oItem.Start = StartDate + TimeValue("00:00")
'Set End Date
oItem.End = EndDate + TimeValue("00:30")
'appointment subject
oItem.Subject = Title & " - " & BuildingofWork
'location description
oItem.Location = BuildingofWork
'Display
oItem.Display
'Create Appointment Details
oItem.Recipients.Add ("CR Notification Group")
'set the busy status
oItem.BusyStatus = olFree
'reminder before start
oItem.ReminderMinutesBeforeStart = 15
'reminder activated
oItem.ReminderSet = True
'Paste Details to Appointment body message
Worksheets("Drop Down and Pastes").Range("C2:D22").Copy
Dim oInspector As Object
Dim oWordEditor As Object
Dim oWindow As Object
Set oInspector = oItem.GetInspector
'oInspector.Activate
Set oWordEditor = oInspector.WordEditor
oWordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
'Reset Variables
Set ol = Nothing
Set oItem = Nothing
End Sub