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

 

[combo]

Firstly, check if you have reference to word library, if not, declare [tt]Const wdPasteRTF =2[/tt], otherwise it is 0 in the marked line.
Before [tt]Set ol = CreateObject("Outlook.Application")[/tt] check if outlook is open, create outlook conditionally:

On Error Resume Next
Set ol = GetObject(, "Outlook.Application")
On Error GoTo 0
If ol Is Nothing Then Set ol = CreateObject("Outlook.Application")

combo

 

[DylaBrion]

Hi COmbo

I have updated the code as suggested and still experiencing the issue. My updated code is below

Any further help or advise would be appreciated

Many Thanks

Sub Sample()

ActiveWorkbook.Save
Dim ol As Object
Dim Item As Object
Const wdPASTERTF = 2
 Const olAppointmentItem = 1
 'item As AppointmentItem
On Error Resume Next
Set ol = GetObject(, "Outlook.Application")
On Error GoTo 0
If ol Is Nothing Then Set ol = CreateObject("Outlook.Application")

'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:C22").Copy
Item.Display
[highlight ]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

 

[combo]

With outlook already open your code works for me. A new appointment item is created basing on active sheet and "Drop Down and Pastes" sheet.
No reference to Word and Outlook libraries.
Does the code stops when outlook is both closed and opened?
You could try to debug the long path using immediate window and test objects, i.e declare [tt]oTest[/tt] and next [tt]Set oTest=Item.GetInspector[/tt], add breakpoint in next line and check [tt]oTest[/tt]. If it's OK, add next property/method ([tt]WordEditor[/tt] here) and test again.

For clarity you can also declare olFree=0 and use oItem instead of Item, to avoid nabes identical to objects.

combo

 

[DylaBrion]

Hi Combo

Many Thanks

I will try this and let you know

For reference the code often works for me when outlook is open. However, roughly every third or fourth attempt experiences the problem.

Thanks again

 

[DylaBrion]

Hi Combo

Apologies but I'm a real novice here

I have opened the immediate window but no idea what to do next

If you could provide more help I'd really appreciate it

Thanks

 

[combo]

Sorry, wdPasteRTF=1 in word.
I was thinking about "Locals" window. When the code is running (so the breakpoint, you need to see current state), it displays locally declared variables and their current values. Expand object variable tree. Sometimes it's a bit confusing when you try to expand endless branch: Application has Application property that returns Application object, etc.

When digging the object structure, you expand the branch you are interested in. If you use code, for instanceit can be done with:
[pre]dim oInspector as object, oWordEditor As Object, oWindow As Object
Set oInspector = Item.GetInspector
Set oWordEditor = oInspector.WordEditor
Set oWindow = oWordEditor.windows(1)
MsgBox oWindow.Selection[/pre]
In case of error you can precisely see the source.

There is something wrong in the line:
[tt]Item.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF[/tt]
PasteAndFormat has no wdPasteRTF, argument, you should put any of WdRecoveryType enumerated constants, and they take neither 1 nor 2. wdPasteRTF is a member of WdPasteDataType enum, which is a DataType argument type in PasteSpecial (instead of PasteAndFormat for Selection).

Generally, I recommend reviewing outlook and word object libraries (in outlook and word VBE object browsers). Note that without referencing outlook and word libraries (late binding) outlook and word named constants are not recognised in vba, they have default values, so you have either declare local constants (as: Const olAppointmentItem = 1) or use values (as: Set Item = ol.CreateItem(1)).



combo

 

[DylaBrion]

Hi Combo

I have tried your recommendation and although I do not get the fault every time I do still see the fault

The coded stops at the line highlighted. Do you have any ideas on what could be causing this

Thanks

Here is the code

Dim oInspector As Object, oWordEditor As Object, oWindow As Object
Set oInspector = Item.GetInspector
[COLOR=#FCE94F]Set oWordEditor = oInspector.WordEditor[/color]
Set oWindow = oWordEditor.Windows(1)
MsgBox oWindow.Selection



Item.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF

 

[combo]

[tt]WordEditor[/tt] property should return [tt]Word.Document[/tt] object for the appointment item. There is a problem here. Any rules for the fault?
Try to add references to word and outlook, comment constants declarations (vba will take their values from referenced libraries), does the code still breaks?

combo

 

[DylaBrion]

Hi Combo

I have added the references to MS Word 15.0 Object Library and MS Outlook 15.0 Object Library

I am seeing the following message

Run Time Error '-2147023170 (800706be)':
Automation Error
The remote procedure call failed.

Thanks

 

[combo]

Please post the testing code after all changes and references set.
Comment the line that generates error. Does the code create appointment item without pasted data?

combo

 

[DylaBrion]

Hi Combo

Code is below with the highlighted line that generates the error
The code does create the appointment item without pasted data
Please note that the error seems to be generated every second time the code is run

Thanks

Sub option_explicit_CreateMeeting_Click()

Dim ol As Object
Dim Item As Object
Dim OutApp3 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

Dim oInspector As Object
Dim oWordEditor As Object
Dim oWindow As Object
Const wdPASTERTF As Long = 1
Set oInspector = Item.GetInspector
[highlight #FCE94F]Set oWordEditor = oInspector.WordEditor[/highlight]
Set oWindow = oWordEditor.Windows(1)
MsgBox oWindow.Selection



Item.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
 
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

 

[combo]

What Office version do you have? Problems with WordEditor in 2007 and 2010 were reported (here and here). Outlook 2003 requires editor setting. In one of linked threads activation of Inspector solved the issue.
Try:

Set oInspector = Item.GetInspector
oInspector.Activate
Set oWordEditor = oInspector.WordEditor
oWordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF

Do you still have an error in third line?

combo

 

[DylaBrion]

Hi Combo

I am using MS Office 2013

I have copied your code and now getting an error on the highlighted code

The appointment is being created and then stops. Please note that this happens every second time I run the code

Thanks for your continued help

Dim oInspector As Object
Dim oWordEditor As Object
Dim oWindow As Object
Const wdPASTERTF As Long = 1
Set oInspector = Item.GetInspector
[highlight #FCE94F]oInspector.Activate[/highlight]
Set oWordEditor = oInspector.WordEditor
oWordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF

 

[combo]

For sanity change variable name [tt]Item[/tt] to [tt]oItem[/tt] (Item can be used in referenced libraries).

Similarly to your other post, do not create another Outlook when Outlook is already open. The code suggested in this post:
On Error Resume Next
[tt]Set OutApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If OutApp Is Nothing Then
' Outlook not open
Set OutApp = CreateObject("Outlook.Application")
End If[/tt]

Test if oInspector exists:
[tt]Set oInspector = Item.GetInspector
MsgBox oInspector Is Nothing
oInspector.Activate[/tt]

Explore "Locals" window after the code broke.



combo

 

[DylaBrion]

Hi Combo

Thanks for your advice again which I will update and check

I thought I'd mention the following as I'm sure it will be important as I have just noticed this

If I minimize the appointment item after I have created it, I can create another appointment item with no issues. I have done this about 20 times with no problem

When I cancel the appointment item (and do not save changes) by clicking the red cross (top right) I get the issue the next time I try to create the appointment item

Hope this makes sense

Thanks

 

[combo]

First of all, you need a clean code and understand what you are doing:
1)
[tt]Sub option_explicit_CreateMeeting_Click()[/tt]
If the "option_explicit" in a procedure name is a consequence of Andrzejek's tip in your other thread, it does nothing here. You need it at a top of module (as in example) and it refers to all its contents.
2)
[tt]Dim ol As Object
...
Dim OutApp3 As Object
...
Set ol = CreateObject("Outlook.Application")[/tt]
You don't need OutApp3. You don't need new Outlook each time you run the code, so use current Outlook if it is open (so GetObject and, only if error, CreateObject).
3)
If you have references to Outlook and Word libraries, allow VBA to read their variables directly (as olAppointmentItem, wdPasteRTF, olFree, NB the last one not defined). In this case comment or delete variable definitions. To see their values, search Word or Outlook libraries.
4)
[tt]'duh! save the thing!
Item.Display
'garbage collection - kind of...
Set ol = Nothing
Set Item = Nothing[/tt]
You don't save the item. Just display it again (as a couple of lines above). Next, VBA variables are reset, but you stay with appointment and Outlook open.

combo

 

[DylaBrion]

Hi Combo

I've now set Option Explicit on all code and declared variables. I think I have made the other changes you suggested and still having the issue

The code stops at the highlighted line

Also to mention my earlier comment

It seems that there is no issue when I create the appointment and send, save or minimize. If I close / cancel the appointment and do not save changes then I get the issue the next time I run the code

I have opened the locals window but I'm really not sure what I am looking at. Sorry as I am still (and continually) learning.

My Code is below

Sub CreateCalendarSchedule2_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
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
'body message
Worksheets("Drop Down and Pastes").Range("C2:D22").Copy
oItem.Display

'Paste Details to Appointment
Dim oInspector As Object
Dim oWordEditor As Object
Dim oWindow As Object
Set oInspector = oItem.GetInspector
[highlight #FCE94F]oInspector.Activate[/highlight]
Set oWordEditor = oInspector.WordEditor
oWordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF

'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

'Display
oItem.Display

'Reset Variables
Set ol = Nothing
Set oItem = Nothing

End Sub

 

[combo]

Tell vba to continue if no outlook is open (GetObject fails in this case):
[pre]'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[/pre]
I assume that your vba project has reference to Outlook library. Probably you have no reference to Word - add it.
Start the code with open Outlook. Close Outlook and run it again. try with open Word.
Try without [tt]oInspector.Activate[/tt].
Examine oInspector Object in 'Locals' window, check child objects and variables.
Check Outlook settings, esp. editors set (if this can be set).

Currently I have no access to Outlook, I will be able to check it late next week.


combo

 

[DylaBrion]

Thanks Combo

I will check and let you know