erichamion
Member
- Outlook version
- Outlook 2013 64 bit
- Email Account
- Exchange Server
I'm trying to create an appointment from a template, then make specific substitutions throughout the subject, location, and body of the appointment. The body substitutions are done with the WordEditor because I need to preserve formatting. It's almost working, but there's a quirk I can't figure out. Any help would be greatly appreciated.
The appointment is created, and the substitutions appear to work, but I then actually need to save changes through the user interface in order for the body substitutions to remain. When I open the appointment for the first time and then close it with the red "X", I'm prompted whether to save changes. If I choose "No", then the subject and location remain correct, but the appointment body reverts back to the template. If I move the meeting to a different time before ever opening it, then the body reverts without any prompt (although, again, the subject and location keep their substitutions).
I can work around the first issue easily by always saving changes or using the "Save and Close" button. The second issue (yes, it's really just a different aspect of the same issue) is a big problem because these appointments do typically get moved around. If I'm careless and don't open the appointment first, then it's lost.
Could somebody please help with identifying what I'm missing? Thank you.
This is using Outlook 2013, and the calendar is on an Exchange server. The script below requires a reference to the Word object library, and templatePath should be changed to the location of a meeting template that has one or more of the strings "<<~Foo~>>", "<<~Bar~>>", and "<<~Baz~>>" in both the subject and the body.
The appointment is created, and the substitutions appear to work, but I then actually need to save changes through the user interface in order for the body substitutions to remain. When I open the appointment for the first time and then close it with the red "X", I'm prompted whether to save changes. If I choose "No", then the subject and location remain correct, but the appointment body reverts back to the template. If I move the meeting to a different time before ever opening it, then the body reverts without any prompt (although, again, the subject and location keep their substitutions).
I can work around the first issue easily by always saving changes or using the "Save and Close" button. The second issue (yes, it's really just a different aspect of the same issue) is a big problem because these appointments do typically get moved around. If I'm careless and don't open the appointment first, then it's lost.
Could somebody please help with identifying what I'm missing? Thank you.
This is using Outlook 2013, and the calendar is on an Exchange server. The script below requires a reference to the Word object library, and templatePath should be changed to the location of a meeting template that has one or more of the strings "<<~Foo~>>", "<<~Bar~>>", and "<<~Baz~>>" in both the subject and the body.
Code:
Option Explicit
Sub calTest()
Dim fields As Collection
Const templatePath As String = "E:\Example.oft"
Set fields = getFieldsTest()
fillTemplateTest fields, templatePath
End Sub
Sub fillTemplateTest(fields As Collection, templatePath As String)
Dim objAppointment As Outlook.AppointmentItem
Dim appointmentDoc As Word.Document
Dim subject As String
'Dim location As String
Dim baseIndex As Long
Dim indexOne As Long
Dim indexTwo As Long
Dim matchStr As String
Dim replStr As String
Dim textRange As Range
Dim fullText As String
Dim objFind As Word.Find
Set objAppointment = Application.CreateItemFromTemplate(templatePath)
objAppointment.Start = Now
objAppointment.End = DateAdd("n", 30, Now)
subject = objAppointment.subject
indexOne = InStr(subject, "<<~")
Do While indexOne > 0
indexTwo = InStr(indexOne, subject, "~>>")
If indexTwo > indexOne Then
matchStr = Mid(subject, indexOne, indexTwo - indexOne + 3)
replStr = ""
On Error Resume Next
replStr = fields.Item(Mid(matchStr, 4, Len(matchStr) - 6))
On Error GoTo 0
subject = Replace(subject, matchStr, replStr)
indexOne = indexOne - 1
End If
indexOne = InStr(indexOne + 1, subject, "<<~")
Loop
objAppointment.subject = subject
'Repeat the above block using objAppointment.location
'Removed from example as unnecessary. Modifying location
'works just as well as modifying subject.
'Adding the line below so that we save before getting the WordEditor
'(and still save again later on) made no difference
'objAppointment.Save
Set appointmentDoc = objAppointment.GetInspector.WordEditor
Set textRange = appointmentDoc.Range
fullText = textRange.Text
indexOne = InStr(fullText, "<<~")
Do While indexOne > 0
indexTwo = InStr(indexOne, fullText, "~>>")
If indexTwo > indexOne Then
Set objFind = textRange.Find
objFind.Text = Mid(fullText, indexOne, indexTwo - indexOne + 3)
replStr = " "
On Error Resume Next
replStr = fields.Item(Mid(objFind.Text, 4, Len(objFind.Text) - 6))
On Error GoTo 0
If objFind.Execute Then
textRange.Text = replStr
indexOne = baseIndex
Else
baseIndex = indexOne
End If
Set textRange = appointmentDoc.Range
fullText = textRange.Text
End If
indexOne = InStr(indexOne + 1, fullText, "<<~")
Loop
objAppointment.Save
Set objAppointment = Nothing
'Adding the line below immediately discards all changes to the
'appointment body.
'appointmentDoc.Close
'Adding the line below prompts the user for a location
'to save a file, which is not what we want.
'appointmentDoc.Save
Set appointmentDoc = Nothing
End Sub
Function getFieldsTest() As Collection
Dim RetVal As Collection
Set RetVal = New Collection
RetVal.Add Item:="Pike", key:="Foo"
RetVal.Add Item:="Kirk", key:="Bar"
RetVal.Add Item:="Picard", key:="Baz"
Set getFieldsTest = RetVal
Set RetVal = Nothing
End Function