Setting appointment label

Status
Not open for further replies.
P

Paul

Hi,

I'm using office 2003.

I'm using the code below to change the label for my appointments based on

the subject contents, but when I run the code not all the appointments are

changed to the assigned label. Some will stay white...

Any ideas anybody?

Cheers,

Paul

Sub Label()

Dim objOutlook As New Outlook.Application

Dim objNamespace As Outlook.NameSpace

Dim objFolder As Outlook.MAPIFolder

Dim objAppointement As Outlook.AppointmentItem

Dim objAttachment As Outlook.Attachment

Dim objNetwork As Object

Dim lngDeletedAppointements As Long

Dim lngCleanedAppointements As Long

Dim lngCleanedAttachments As Long

Dim blnRestart As Boolean

Dim intDateDiff As Integer

Set objOutlook = Outlook.Application

Set objNamespace = objOutlook.GetNamespace("MAPI")

Set objFolder =

objNamespace.GetFolderFromID("00000000AAAEAB88111BB14FB3930A1FFF7C2A9101000EF192502C04154AB66E62534AEC6E18002B0EF780E70000")

For Each objAppointement In objFolder.Items

DoEvents

If objAppointement.Subject = "x" Then

Call SetApptColorLabel(objAppointement, 1)

ElseIf objAppointement.Subject = "y" Then

Call SetApptColorLabel(objAppointement, 2)

ElseIf objAppointement.Subject = "r" Then

Call SetApptColorLabel(objAppointement, 3)

ElseIf objAppointement.Subject = "t" Then

Call SetApptColorLabel(objAppointement, 4)

ElseIf objAppointement.Subject = "g" Then

Call SetApptColorLabel(objAppointement, 5)

End If

Next

End Sub

Sub SetApptColorLabel(objAppt As Object, _

intColor As Integer)

Const CdoPropSetID1 = "0220060000000000C000000000000046"

Const CdoAppt_Colors = "0x8214"

Dim objCDO As Object

Dim objMsg As Object

Dim colFields As Object

Dim objField As Object

Dim strMsg As String

Dim intAns As Integer

On Error Resume Next

Set objCDO = CreateObject("MAPI.Session")

objCDO.Logon "", "", False, False

If Not objAppt.EntryID = "" Then

Set objMsg = objCDO.GetMessage(objAppt.EntryID, objAppt.Parent.StoreID)

Set colFields = objMsg.Fields

Set objField = colFields.Item(CdoAppt_Colors, CdoPropSetID1)

If objField Is Nothing Then

Err.Clear

Set objField = colFields.Add(CdoAppt_Colors, vbLong, intColor, CdoPropSetID1)

Else

objField.Value = intColor

End If

objMsg.Update True, True

Else

strMsg = "You must save the appointment before you add a color label. " & _

"Do you want to save the appointment now?"

intAns = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Set Appointment Color

Label")

If intAns = vbYes Then

Call SetApptColorLabel(objAppt, intColor)

Else

Exit Sub

End If

End If

Set objAppt = Nothing

Set objMsg = Nothing

Set colFields = Nothing

Set objField = Nothing

objCDO.Logoff

Set objCDO = Nothing

End Sub
 
Where is this code running? If it's in the Outlook VBA project you should

never use New to set an Outlook.Application object, use the intrinsic and

trusted Application object. If it's not running in Outlook then using New

set objOutlook, don't set it again.

Never hard code a folder or item EntryID. If this is the default Calendar

folder use objNamespace.GetDefaultFolder(olFolderCalendar).

Are you getting any errors? I could see problems arising from the constant

logging into and out of CDO sessions. You should do the CDO session creation

and login once and use a global or pass the CDO.Session object. CDO does

have some memory leaks when you do multiple login/logoff operations like

that.

I'd comment the error handler so errors will fire or I'd test for errors at

critical points so I could see what's going on, either that or step the code

and see what's happening.

"Paul" <Paul> wrote in message

news:8AB39441-5C1E-431C-9A3E-B359B9A338C0@microsoft.com...
> Hi,

> I'm using office 2003.

> I'm using the code below to change the label for my appointments based on
> the subject contents, but when I run the code not all the appointments are
> changed to the assigned label. Some will stay white...

> Any ideas anybody?

> Cheers,

> Paul

> Sub Label()

> Dim objOutlook As New Outlook.Application
> Dim objNamespace As Outlook.NameSpace
> Dim objFolder As Outlook.MAPIFolder
> Dim objAppointement As Outlook.AppointmentItem
> Dim objAttachment As Outlook.Attachment
> Dim objNetwork As Object
> Dim lngDeletedAppointements As Long
> Dim lngCleanedAppointements As Long
> Dim lngCleanedAttachments As Long
> Dim blnRestart As Boolean
> Dim intDateDiff As Integer

> Set objOutlook = Outlook.Application
> Set objNamespace = objOutlook.GetNamespace("MAPI")
> Set objFolder =
> objNamespace.GetFolderFromID("00000000AAAEAB88111BB14FB3930A1FFF7C2A9101000EF192502C04154AB66E62534AEC6E18002B0EF780E70000")

> For Each objAppointement In objFolder.Items
> DoEvents
> If objAppointement.Subject = "x" Then
> Call SetApptColorLabel(objAppointement, 1)
> ElseIf objAppointement.Subject = "y" Then
> Call SetApptColorLabel(objAppointement, 2)
> ElseIf objAppointement.Subject = "r" Then
> Call SetApptColorLabel(objAppointement, 3)
> ElseIf objAppointement.Subject = "t" Then
> Call SetApptColorLabel(objAppointement, 4)
> ElseIf objAppointement.Subject = "g" Then
> Call SetApptColorLabel(objAppointement, 5)
> End If
> Next

> End Sub

> Sub SetApptColorLabel(objAppt As Object, _
> intColor As Integer)

> Const CdoPropSetID1 = "0220060000000000C000000000000046"
> Const CdoAppt_Colors = "0x8214"
> Dim objCDO As Object
> Dim objMsg As Object
> Dim colFields As Object
> Dim objField As Object
> Dim strMsg As String
> Dim intAns As Integer
> On Error Resume Next

> Set objCDO = CreateObject("MAPI.Session")
> objCDO.Logon "", "", False, False
> If Not objAppt.EntryID = "" Then
> Set objMsg = objCDO.GetMessage(objAppt.EntryID, objAppt.Parent.StoreID)
> Set colFields = objMsg.Fields
> Set objField = colFields.Item(CdoAppt_Colors, CdoPropSetID1)
> If objField Is Nothing Then
> Err.Clear
> Set objField = colFields.Add(CdoAppt_Colors, vbLong, intColor,
> CdoPropSetID1)
> Else
> objField.Value = intColor
> End If
> objMsg.Update True, True
> Else
> strMsg = "You must save the appointment before you add a color label. " &
> _
> "Do you want to save the appointment now?"
> intAns = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Set Appointment Color
> Label")
> If intAns = vbYes Then
> Call SetApptColorLabel(objAppt, intColor)
> Else
> Exit Sub
> End If
> End If

> Set objAppt = Nothing
> Set objMsg = Nothing
> Set colFields = Nothing
> Set objField = Nothing
> objCDO.Logoff
> Set objCDO = Nothing
> End Sub
>
 
Status
Not open for further replies.
< Outlook2007 Email problem with automation | Addin to define message format on a per-contact basis? >
Similar threads
Thread starter Title Forum Replies Date
K setting up appointment from to-do bar Using Outlook 1
T Removing time zone setting from an appointment / meeting: is it possible? Using Outlook 2
J Outlook Appointment recurrence setting Outlook VBA and Custom Forms 4
V Setting up Outlook 2021 on new computer Using Outlook 2
AlphonseG Outlook 365 Outlook Crashes on setting SaveSentMessageFolder Outlook VBA and Custom Forms 4
R Outlook 2021 Having problem setting up outlook 2021 with windows 11. I have 3 gmail accounts and I want the 3 gmail, emails to merge into the same outlook input. Using Outlook.com accounts in Outlook 0
e_a_g_l_e_p_i Outlook 2010 Help setting up Gmail account in Outlook 2010 Using Outlook 3
P OWA Settings->Calendar->Events from Email; Setting changes do not hold Using Outlook 1
Marc2019 Setting up an Outlook Account on Mac Os 10.6.8 Outlook 2011 Using Outlook 1
L Outlook Office 365 client: won't remember my setting File, not to collapse ribbon Using Outlook 2
M Where is the setting to *turn off* open calendar in a new window? Using Outlook 3
llama_thumper Setting up forwarders on Exchange server Exchange Server Administration 0
B Setting rules Using Outlook 1
C iCloud Setting missing Outlook tab and Outlook missing the iCloud refresh button Using Outlook 4
B Setting defaults Using Outlook 2
C need help setting up outlook first time Using Outlook 1
P Reading Pane (Reading Pain?) Default Setting Using Outlook 1
W Setting up a custom form Outlook VBA and Custom Forms 2
mctabish Setting "Reply To" based on inbox Outlook VBA and Custom Forms 2
R Setting font and color used when replying to an email Outlook VBA and Custom Forms 3
M Setting flag follow up for next business day Outlook VBA and Custom Forms 1
Ed Sheehan Unusual behaviour in setting Sender (Outlook 2016) Outlook VBA and Custom Forms 4
Jennifer Murphy Equations don't comply with style setting to left justify Using Outlook 0
J Setting default address book Using Outlook 0
N Does a Shared Folder Policy override a Digital Signature Setting for macros? Outlook VBA and Custom Forms 6
Diane Poremsky Setting up an Outlook.com IMAP account Using Outlook 0
Diane Poremsky Setting the default Country for Outlook Contacts Using Outlook 0
H Need help setting up GetFolderPath-Makro with Vodafone IMAP Mail-Account Outlook VBA and Custom Forms 0
Diane Poremsky Adjusting Outlook's Zoom setting in Email Using Outlook 0
O Setting default format for composing/replying to emails Using Outlook 3
B Outlook Calendar/setting appointments Using Outlook 1
Diane Poremsky Adjusting Outlook's Zoom setting in Email Using Outlook 0
Diane Poremsky Setting Custom Reminder Times Using Outlook 0
A Can't stop Outlook.com from setting reminders on appointments? Using Outlook.com accounts in Outlook 3
A Setting RULES with more than one condition in MS OUTLOOK Using Outlook 6
L Setting up my PA's Outlook Using Outlook 7
E Need Help on Setting up a repeated Reminder on Task with Reoccurence Every Year Using Outlook 6
N "Instant Search" setting a default view Using Outlook 3
H SETTING UP A "NEW" NEVER HAD NEVER USED EMAIL ACCOUNT Using Outlook 9
K Setting Default Email Address for Meeting Replies Using Outlook 3
S Setting up Outlook 2010 to work with custom domain outlook.com account BCM (Business Contact Manager) 3
D Setting defult "Show a room list" Using Outlook 0
Horsepower Setting appointments in calendar Using Outlook 3
J Setting tabs in contacts / notes field Using Outlook 0
T Setting a Default Subject from a certain Signature Using Outlook 0
K Help Needed - setting up Email in Outlook 2013 Using Outlook 3
mikecox setting Default area code in Contacts Using Outlook 5
G Outlook2013 - "From" name doesn't change even when changed in Account Setting Using Outlook 4
D How do I start completely from scratch in setting up Outlook 2013? Using Outlook 6
V View zoom setting changing Using Outlook 1

Similar threads

Back
Top