Bug When opening outlook to create a calendar entry 1

[DylaBrion]

To All

Can anyone help. I have some code (pasted below) which opens outlook from excel and creates a calendar invite. It works fine for about 70% of the time. For the remaining 30% I receive an error message stating the Microsoft Outlook has stopped working. When I click debug the line is highlighted as below. It seems that it may be happening when outlook is already open. I have tried to repeat the issue when outlook is closed when the code is triggered and cannot repeat the issue.

As always, any help would be appreciated

Here is the code

Sub Sample()

ActiveWorkbook.Save
Dim ol As Object
Dim Item As Object
 Const olAppointmentItem = 1
 'item As AppointmentItem
 Set ol = CreateObject("Outlook.Application")
 Set Item = ol.CreateItem(olAppointmentItem)
 
    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]
    
 'Set Start Date
 Item.Start = StartDate + TimeValue("00:00")
  'Set End Date
 Item.End = EndDate + TimeValue("00:30")
 'appointment subject
 Item.Subject = Title & " - " & BuildingofWork
 'location description
 Item.Location = BuildingofWork
 'body message
 Worksheets("Drop Down and Pastes").Range("C2:D22").Copy
Item.Display
[highlight #FCE94F]Item.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF[/highlight]
 
 Item.Recipients.Add ("CR Notification Group")
 'set the busy status
 Item.BusyStatus = olFree
 'reminder before start
 Item.ReminderMinutesBeforeStart = 15
 'reminder activated
 Item.ReminderSet = True
 'duh! save the thing!
 Item.Display

 'garbage collection - kind of...
 Set ol = Nothing
 Set Item = Nothing

 'return true
 makeReminder = True
 End Sub

 

[DylaBrion]

Hi Combo

I applied most of your suggested changes and still had an issue. I then spent some time changing the sequence of actions within the code and I am very please to say that I have run the code many times with no issues
Thanks so much for your patience and help
It really is appreciated

For reference the final code is below

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
Set oItem = ol.CreateItem(olAppointmentItem)
'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