Setting Appointment Labels Using Redemption

M

Mark Milliman

I thought I had the problem licked until Outlook crashed and I lost my VBA
project. I recreated it quickly from memory. After a week of using the
recreated scripts, I noticed that the script that I have to set a new
appointment's color does not work. Well, sort of. The appointment is
colored in the calendar view. When I open the appointment, the label is set
to none.

I am using Redemption to bypass the security warnings from CDO. Instead of
using Sue's CDO code, I am using another function I found. I think my
problem is that I need to create the label first before setting it, but I am
not sure how to do that. Can someone point out the errors of my ways?

Public Sub WebinarAppt()
'This subroutine uses Redemption in various places

Dim objAppt
Dim objMsg
Dim oAItem, oMItem
Dim ErrFlag As Boolean
Dim dateStr, preambleStr, prologStr, subjectStr, timeStr As String
Dim dateStrLength As Integer
Dim timeOffset
Dim StartDate

ErrFlag = False
Set objMsg = CreateObject("Redemption.SafeMailItem")
Set oMItem = GetCurrentItem()
objMsg.Item = oMItem
Set objAppt = CreateObject("Redemption.SafeAppointmentItem")
Set oAItem = Application.CreateItem(olAppointmentItem)
objAppt.Item = oAItem
timeStr = "12:00 PM"
'Time difference from EST hardcoded to MST
timeOffset = -2

'Check to make sure that something was selected
If Not objMsg.Item Is Nothing Then
'Check to make sure that the selected item is a legitimate Webinar
message
strTest = Left(objMsg.Subject, 19)
If objMsg.Class = olMail And _
objMsg.SenderEmailAddress = "(e-mail address removed)" And _
StrComp(strTest, "LOG-IN INSTRUCTIONS", vbTextCompare) = 0 Then
'Parse message subject for subject of appointment
subjectStr = Trim(objMsg.Subject)
startPos = InStr(subjectStr, " - ") + 3
endPos = InStrRev(subjectStr, " - ")
strSize = endPos - startPos
subjectStr = Mid(subjectStr, startPos, strSize)

'Parse message subject for date of webinar
dateStrLength = Len(Trim(objMsg.Subject)) - (endPos + 2)
dateStr = Right(Trim(objMsg.Subject), dateStrLength)

'Parse the message body for the starting time
startPos = InStr(objMsg.HTMLBody, "<b>Time: ") + 9
endPos = InStr(startPos, objMsg.HTMLBody, "m.") + 2
strSize = endPos - startPos
timeStr = Mid(objMsg.HTMLBody, startPos, strSize)
timeStr = Replace(timeStr, ".", "")
If IsDate(dateStr) And IsDate(timeStr) Then
StartDate = DateAdd("h", timeOffset, CDate(dateStr & " " &
timeStr))
End If

'Parse message body
startPos = InStr(objMsg.HTMLBody, "Thank you for registering
") - 1
preambleStr = Left(objMsg.HTMLBody, startPos)
endPos = InStr(1, objMsg.HTMLBody, "London") + 19
strSize = Len(objMsg.HTMLBody)
prologStr = Mid(objMsg.HTMLBody, endPos, strSize)

With objAppt
.Subject = subjectStr
.Location = "Webinar"
.Start = StartDate
.Duration = 60
.ReminderMinutesBeforeStart = 5
.Categories = "Education"
.HTMLBody = preambleStr & prologStr
End With
objAppt.Save
Call SetColorCode(objAppt.Item, 5)
objAppt.Display
'objMsg.Delete 'deletes the message
Else
ErrFlag = True
End If
Else
ErrFlag = True
End If

If ErrFlag Then
MsgBox ("Please go to your Inbox and select a LightReading Webinar"
& vbCrLf & _
"invitation, then run again. A proper message was not selected.")
End If

'Clean up objects
Set oAItem = Nothing
Set oMItem = Nothing
Set objAppt = Nothing
Set objMsg = Nothing

End Sub
Function SetColorCode(olAppt As Outlook.AppointmentItem, lngColor As Long)
Const PT_LONG = &H3
Const PropSetID = "{00062002-0000-0000-C000-000000000046}"
Const ApptColors = "0x8214"

Dim lngPropID As Long

On Error Resume Next

Set oSafeAppt = CreateObject("Redemption.SafeAppointmentItem")
oSafeAppt.Item = olAppt
lngPropID = oSafeAppt.GetIDsFromNames(PropSetID, ApptColors) Or PT_LONG
MsgBox ("longPropID = " & lngPropID)
'The oSafeAppt.Fields(lngPropID) corresponds
'to the ordinal value of the label
'1=Important, 2=Business, etc.
oSafeAppt.Fields(lngPropID) = lngColor
olAppt.Save
End Function


Thanks,
Mark

--
________________________________

Mark Milliman
Longmont, Colorado E-mail: (e-mail address removed)
________________________________
 
M

Mark Milliman

I have tried a variety of things today to get it to work, but I have made no
progress. I did simplify the code a bit so I am passing the object instead
of an Outlook.Appointment item. Doing so allowed me to trim 4 lines of
code. Also, I added the label field and set it, but that did not work.
Next I added a message box to return the value of the label after setting
it. It returned 5 just as I wanted. I am perplexed. What am I missing? I
saved the AppointmentItem before and after calling the function. It appears
set because it is showing set in the calendar. It shows a label as none
when I open the appointment item. It seems like the field is hidden to the
form but not Explorer objects.

This really bothers me because I had it right at one point.

Perplexed,
Mark
 
D

Dmitry Streblechenko

Outlook will not see any changes made through Extended MAPI until you
completely dereference the item.
That means saving objAppt, retrieving its entry id, setting objAppt to
Nothing, then reopenning objAppt using Namespace.GetItemfromID.

Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
 
M

Mark Milliman

Dmitry:

Thanks. I knew there was something I was leaving out. I put the required
statements in the code, but I still do not see the label set in the
appointment form. My longPropID for the label is a negative number. Which
leads me to believe that something is wrong. The code executes without
error, but the label still does not display. Is my PropSetID correct? Here
is the current code I have.

Thanks,
Mark

Public Sub WebinarAppt()
'This subroutine uses Redemption in various places

Dim olNS As Outlook.NameSpace
Dim objAppt As Object
Dim objMsg
Dim oAItem, oMItem
Dim ErrFlag As Boolean
Dim dateStr, preambleStr, prologStr, subjectStr, timeStr As String
Dim dateStrLength As Integer
Dim timeOffset, apptID
Dim StartDate

ErrFlag = False
Set objMsg = CreateObject("Redemption.SafeMailItem")
Set oMItem = GetCurrentItem()
objMsg.Item = oMItem
Set objAppt = CreateObject("Redemption.SafeAppointmentItem")
Set oAItem = Application.CreateItem(olAppointmentItem)
objAppt.Item = oAItem
Set olNS = Application.GetNamespace("MAPI")
timeStr = "12:00 PM"
'Time difference from EST hardcoded to MST
timeOffset = -2

'Check to make sure that something was selected
If Not objMsg.Item Is Nothing Then
'Check to make sure that the selected item is a legitimate Webinar
message
strTest = Left(objMsg.Subject, 19)
If objMsg.Class = olMail And _
objMsg.SenderEmailAddress = "(e-mail address removed)" And _
StrComp(strTest, "LOG-IN INSTRUCTIONS", vbTextCompare) = 0 Then
'Parse message subject for subject of appointment
subjectStr = Trim(objMsg.Subject)
startPos = InStr(subjectStr, " - ") + 3
endPos = InStrRev(subjectStr, " - ")
strSize = endPos - startPos
subjectStr = Mid(subjectStr, startPos, strSize)

'Parse message subject for date of webinar
dateStrLength = Len(Trim(objMsg.Subject)) - (endPos + 2)
dateStr = Right(Trim(objMsg.Subject), dateStrLength)

'Parse the message body for the starting time
startPos = InStr(objMsg.HTMLBody, "<b>Time: ") + 9
endPos = InStr(startPos, objMsg.HTMLBody, "m.") + 2
strSize = endPos - startPos
timeStr = Mid(objMsg.HTMLBody, startPos, strSize)
timeStr = Replace(timeStr, ".", "")
If IsDate(dateStr) And IsDate(timeStr) Then
StartDate = DateAdd("h", timeOffset, CDate(dateStr & " " &
timeStr))
End If

'Parse message body
startPos = InStr(objMsg.HTMLBody, "Thank you for registering
") - 1
preambleStr = Left(objMsg.HTMLBody, startPos)
endPos = InStr(1, objMsg.HTMLBody, "London") + 19
strSize = Len(objMsg.HTMLBody)
prologStr = Mid(objMsg.HTMLBody, endPos, strSize)

With objAppt
.Subject = subjectStr
.Location = "Webinar"
.Start = StartDate
.Duration = 60
.ReminderMinutesBeforeStart = 5
.Categories = "Education"
.HTMLBody = preambleStr & prologStr
End With

'Make the appointment useable by Extended MAPI
objAppt.Save
apptID = objAppt.EntryID
Set objAppt = Nothing
Set objAppt = olNS.GetItemFromID(apptID)

'Set the appointment label
Call SetColorCode(objAppt, 5)
objAppt.Display
'objMsg.Delete 'deletes the message
Else
ErrFlag = True
End If
Else
ErrFlag = True
End If

If ErrFlag Then
MsgBox ("Please go to your Inbox and select a LightReading Webinar"
& vbCrLf & _
"invitation, then run again. A proper message was not selected.")
End If

'Clean up objects
Set oAItem = Nothing
Set oMItem = Nothing
Set objAppt = Nothing
Set objMsg = Nothing

End Sub
Function SetColorCode(olAppt As Outlook.AppointmentItem, lngColor As Long)
Const PT_LONG = &H3
Const PropSetID = "{00062002-0000-0000-C000-000000000046}"
Const ApptColors = "0x8214"

Dim lngPropID As Long

'On Error Resume Next

Set oSafeAppt = CreateObject("Redemption.SafeAppointmentItem")
oSafeAppt.Item = olAppt
lngPropID = oSafeAppt.GetIDsFromNames(PropSetID, ApptColors) Or PT_LONG
'The oSafeAppt.Fields(lngPropID) corresponds
'to the ordinal value of the label
'1=Important, 2=Business, etc.
oSafeAppt.Fields(lngPropID) = lngColor
olAppt.Save
End Function
 
D

Dmitry Streblechenko

You also need to set oAItem to Nothing when you set objAppt to Nothing
before calling GetItemfromID

Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
 
M

Mark Milliman

Dmitry:

I already tried the "Set oAItem = Nothing" before calling GetItemfromID when
it didn't work tonight. I also tried adding the label field and many minor
things. None of them worked. The only thing I can think of is that I don't
have the correct property ID for the label or the label field is not fully
enumerated in the appointment item. The problem is that the correct label
shows on the calendar just not in the form.

Thanks,
Mark
 
D

Dmitry Streblechenko

Oh wait, you need to set the custom prop using Redemption *before* you set
all the objects to Nothing and reopen the item using GetItemfromID.
It is not a problem of making an object usable through Extended MAPI, it is
a problem of Outlook not seeing Extended MAPI changes.

Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
 
M

Mark Milliman

Dmitry:

I appreciate your patience helping me with this issue. I am still fumbling
trying to understand the Outlook object model. I changed the code per your
instructions, but I still can't get it to work. I simplified the subroutine
by removing the function (I only use it once). I set the label property,
save the Redemption objAppt, get the EntryID, set them to nothing, then call
the object back. What am I missing?

My new code is below.

Thanks again,
Mark

Public Sub WebinarAppt()
'This subroutine uses Redemption in various places

Const PT_LONG = &H3
Const PropSetID = "{00062002-0000-0000-C000-000000000046}"
Const ApptColors = "0x8214"

Dim objAppt As Object
Dim objMsg
Dim oAItem, oMItem
Dim ErrFlag As Boolean
Dim dateStr, preambleStr, prologStr, subjectStr, timeStr As String
Dim dateStrLength As Integer
Dim timeOffset As Integer
Dim StartDate
Dim appID, lngPropID As Long

ErrFlag = False
Set objMsg = CreateObject("Redemption.SafeMailItem")
Set oMItem = GetCurrentItem()
objMsg.Item = oMItem
Set objAppt = CreateObject("Redemption.SafeAppointmentItem")
Set oAItem = Application.CreateItem(olAppointmentItem)
objAppt.Item = oAItem
timeStr = "12:00 PM"
'Time difference from EST hardcoded to MST
timeOffset = -2

'Check to make sure that something was selected
If Not objMsg.Item Is Nothing Then
'Check to make sure that the selected item is a legitimate Webinar
message
strTest = Left(objMsg.Subject, 19)
If objMsg.Class = olMail And _
objMsg.SenderEmailAddress = "(e-mail address removed)" And _
StrComp(strTest, "LOG-IN INSTRUCTIONS", vbTextCompare) = 0 Then
'Parse message subject for subject of appointment
subjectStr = Trim(objMsg.Subject)
startPos = InStr(subjectStr, " - ") + 3
endPos = InStrRev(subjectStr, " - ")
strSize = endPos - startPos
subjectStr = Mid(subjectStr, startPos, strSize)

'Parse message subject for date of webinar
dateStrLength = Len(Trim(objMsg.Subject)) - (endPos + 2)
dateStr = Right(Trim(objMsg.Subject), dateStrLength)

'Parse the message body for the starting time
startPos = InStr(objMsg.HTMLBody, "<b>Time: ") + 9
endPos = InStr(startPos, objMsg.HTMLBody, "m.") + 2
strSize = endPos - startPos
timeStr = Mid(objMsg.HTMLBody, startPos, strSize)
timeStr = Replace(timeStr, ".", "")
If IsDate(dateStr) And IsDate(timeStr) Then
StartDate = DateAdd("h", timeOffset, CDate(dateStr & " " &
timeStr))
End If

'Parse message body
startPos = InStr(objMsg.HTMLBody, "Thank you for registering
") - 1
preambleStr = Left(objMsg.HTMLBody, startPos)
endPos = InStr(1, objMsg.HTMLBody, "London") + 19
strSize = Len(objMsg.HTMLBody)
prologStr = Mid(objMsg.HTMLBody, endPos, strSize)

With objAppt
.Subject = subjectStr
.Location = "Webinar"
.Start = StartDate
.Duration = 60
.ReminderMinutesBeforeStart = 5
.Categories = "Education"
.HTMLBody = preambleStr & prologStr
End With

'Set the appointment label
lngPropID = objAppt.GetIDsFromNames(PropSetID, ApptColors) Or
PT_LONG
'The oSafeAppt.Fields(lngPropID) corresponds
'to the ordinal value of the label 1=Important, 2=Business, etc.
objAppt.Fields(lngPropID) = 5
'Call SetColorCode(objAppt, 5)

objAppt.Save
apptID = objAppt.EntryID

'Make the appointment useable by Extended MAPI
Set oAItem = Nothing
Set objAppt = Nothing
Set objAppt =
Application.GetNamespace("MAPI").GetItemFromID(apptID)
objAppt.Display
'objMsg.Delete 'deletes the message
Else
ErrFlag = True
End If
Else
ErrFlag = True
End If

If ErrFlag Then
MsgBox ("Please go to your Inbox and select a LightReading Webinar"
& vbCrLf & _
"invitation, then run again. A proper message was not selected.")
End If

'Clean up objects
Set oAItem = Nothing
Set oMItem = Nothing
Set objAppt = Nothing
Set objMsg = Nothing

End Sub
 
D

Dmitry Streblechenko

One more correction: ApptColors is supposed to be an integer - &H8214
(0x8214 in C/C++), not a string.

Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
 
M

Mark Milliman

Good catch Dmitry. As I went to sleep, I thought that I may have a type
issue. I now understand the difference between GUID, PropID, and the tag.
I also noticed the difference in using CDO by passing MAPI messages and
Redemption directly setting the property. If I think I understand, then why
can't I get it right?

I made your change, but the property is still not being set. I set a
breakpoint after "objAppt.Fields(lngPropID) = 5" and took a look at the item
through OutlookSpy. ID 0x8214 was still set to 5 as it should. Just for
good measure I do a oAItem.Save before setting oAItem and objAppt to
nothing. The snippit of code I use is below:
objAppt.Save
apptEID = objAppt.EntryID
apptSID = objAppt.Parent.StoreID

'Set the appointment label
lngPropID = objAppt.GetIDsFromNames(GUID, &H8214) Or PT_LONG
'The oSafeAppt.Fields(lngPropID) corresponds
'to the ordinal value of the label 1=Important, 2=Business, etc.
objAppt.Fields(lngPropID) = 5
oAItem.Save

'Make the appointment useable by Extended MAPI
--> Set oAItem = Nothing
Set objAppt = Nothing
Set objAppt =
Application.GetNamespace("MAPI").GetItemFromID(apptEID, apptSID)
objAppt.Display

When I set the breakpoint at the arrow and open the item, the label is set
to 5 and the later .Display shows the label set to 5. When I remove the
breakpoint and let the whole subroutine run, it is not set. So the problem
has to do with Redemption and MAPI saving the objAppt so Outlook knows the
property has changed. I tried both oAItem.Save and objAppt.Save with the
similar results. Any other thoughts?

Mark
 
M

Mark Milliman

Dmitry:

I wasted the better part of the afternoon trying different things. What was
strange is that I was setting it through MAPI, but Outlook was not
recognizing it completely. At least the property (0x8214) was not set.
Finally I decided to save the appointment (objAppt.Save) right after I
created it. Then I did all of my message processing, changed the label, and
saved it again. IT WORKS!

Not that I am not greatful, but I would like to know why it works. I
originally saved it after adding a bunch of items in the with loop. What
makes it so different that I saved it before adding anything to the object?
Any ideas?

Thanks for all of your help,
Mark

Public Sub WebinarAppt()
'This subroutine uses Redemption in various places

Const PT_LONG = &H3
Const GUID = "{00062002-0000-0000-C000-000000000046}"
Const PropSetID = "0220060000000000C000000000000046"
Const ApptColors = "0x8214"

Dim OutApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim objAppt As Object
Dim objMsg
Dim oAItem, oMItem
Dim objField
Dim ErrFlag As Boolean
Dim dateStr, preambleStr, prologStr, subjectStr, timeStr As String
Dim dateStrLength As Integer
Dim timeOffset As Integer
Dim StartDate
Dim appEID, appSID, lngPropID As Long

ErrFlag = False
Set OutApp = CreateObject("Outlook.Application")
Set olNS = OutApp.GetNamespace("MAPI")
olNS.Logon
Set objMsg = CreateObject("Redemption.SafeMailItem")
Set oMItem = GetCurrentItem()
objMsg.Item = oMItem
Set objAppt = CreateObject("Redemption.SafeAppointmentItem")
Set oAItem = OutApp.CreateItem(olAppointmentItem)
objAppt.Item = oAItem
timeStr = "12:00 PM"
'Time difference from EST hardcoded to MST because I am lazy
timeOffset = -2

objAppt.Save

'Check to make sure that something was selected
If Not objMsg.Item Is Nothing Then
'Check to make sure that the selected item is a legitimate Webinar
message
strTest = Left(objMsg.Subject, 19)
If objMsg.Class = olMail And _
objMsg.SenderEmailAddress = "(e-mail address removed)" And _
StrComp(strTest, "LOG-IN INSTRUCTIONS", vbTextCompare) = 0 Then
'Parse message subject for subject of appointment
subjectStr = Trim(objMsg.Subject)
startPos = InStr(subjectStr, " - ") + 3
endPos = InStrRev(subjectStr, " - ")
strSize = endPos - startPos
subjectStr = Mid(subjectStr, startPos, strSize)

'Parse message subject for date of webinar
dateStrLength = Len(Trim(objMsg.Subject)) - (endPos + 2)
dateStr = Right(Trim(objMsg.Subject), dateStrLength)

'Parse the message body for the starting time
startPos = InStr(objMsg.HTMLBody, "<b>Time: ") + 9
endPos = InStr(startPos, objMsg.HTMLBody, "m.") + 2
strSize = endPos - startPos
timeStr = Mid(objMsg.HTMLBody, startPos, strSize)
timeStr = Replace(timeStr, ".", "")
If IsDate(dateStr) And IsDate(timeStr) Then
StartDate = DateAdd("h", timeOffset, CDate(dateStr & " " &
timeStr))
End If

'Parse message body
startPos = InStr(objMsg.HTMLBody, "Thank you for registering
") - 1
preambleStr = Left(objMsg.HTMLBody, startPos)
endPos = InStr(1, objMsg.HTMLBody, "London") + 19
strSize = Len(objMsg.HTMLBody)
prologStr = Mid(objMsg.HTMLBody, endPos, strSize)

With objAppt
.Subject = subjectStr
.Location = "Webinar"
.Start = StartDate
.Duration = 60
.ReminderMinutesBeforeStart = 5
.Categories = "Education"
.HTMLBody = preambleStr & prologStr
End With

'Set the appointment label
lngPropID = objAppt.GetIDsFromNames(GUID, &H8214) Or PT_LONG
'The oSafeAppt.Fields(lngPropID) corresponds
'to the ordinal value of the label 1=Important, 2=Business, etc.
objAppt.Fields(lngPropID) = 5
objAppt.Save
objMsg.Delete
Else
ErrFlag = True
End If
Else
ErrFlag = True
End If

If ErrFlag Then
MsgBox ("Please go to your Inbox and select a LightReading Webinar"
& vbCrLf & _
"invitation, then run again. A proper message was not selected.")
End If

'Clean up objects
Set OutApp = Nothing
Set olNS = Nothing
Set oAItem = Nothing
Set oMItem = Nothing
Set objAppt = Nothing
Set objMsg = Nothing

End Sub
 
D

Dmitry Streblechenko

Most likely Outlook sets the default values for most properties when the
item is saved for the very first time, overwriting your changes. It does not
do that for the subsequent calls to Save.

Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
 
Top