Select and Flag Multiple Contacts

[Steve Roberts]

I have a need to select a random group of contacts in a public folder and
flag them all with either a blue or yellow flag no follow up time is
required. I understand that I need to use CDO to do this but I am a bit
fuzzy on how to step through all of the selected items. I found the code
below on Eric Legault's site and it works fine for a single contact. Any
suggestions how I might modify this to process multiple selections?

Thanks

Steve


http://blogs.officezealot.com/legault/archive/2004/05/26/213.aspx

Option Explicit

Const CdoPropSetID4 = "0820060000000000C000000000000046"
Const CdoPR_FLAG_TEXT = "{" & CdoPropSetID4 & "}" & "0x8530" 'String
Const CdoPR_FLAG_DUE_BY = "{" & CdoPropSetID4 & "}" & "0x8502" 'Date
Const CdoPR_FLAG_DUE_BY_NEXT = "0x8560" 'Date
Const CdoPR_REPLY_REQUESTED = &HC17000B 'True/False
Const CdoPR_RESPONSE_REQUESTED = &H63000B 'True/False
Const CdoPR_REPLY_TIME = &H300040 'Date
Const CdoPR_FLAG_STATUS = &H10900003
'** I forgot this constant before!
Const CdoPR_REMINDER_SET = "{" & CdoPropSetID4 & "}" & "0x8503"

Sub SetFlagInfoForSelectedContact()
On Error Resume Next

Dim objSession As MAPI.Session, objCDOContact As MAPI.Message
Dim objNS As Outlook.NameSpace, objOLContact As Outlook.ContactItem
Dim objFields As MAPI.Fields, objField As MAPI.Field
Dim strValue As String, strTempDate As String, dteFlagDate As Date

If Application.ActiveExplorer.Selection.Count > 1 Then Exit Sub
Set objOLContact = Application.ActiveExplorer.Selection(1)
If objOLContact.Class <> Outlook.OlObjectClass.olContact Then Exit Sub

Set objNS = Application.GetNamespace("MAPI")
Set objSession = New MAPI.Session
objSession.Logon , , , False

'**check for any logon errors
If Err.Number <> 0 Then GoTo Leave:

Set objCDOContact = objSession.GetMessage(objOLContact.EntryID,
Application.ActiveExplorer.CurrentFolder.StoreID)

'**check for a valid CDO Message
If objCDOContact Is Nothing Then GoTo Leave:

strValue = InputBox("Flag Text value: ", , "Follow up")
If strValue = "" Then
MsgBox "Invalid Flag text"
GoTo Leave:
End If

'DateTime format = m/dd/yyyy hh:mm AM/PM; eg. 5/27/2004 15:00 PM
strTempDate = (InputBox("Flag reminder date (m/dd/yyyy hh:mm AM/PM):"))
If IsDate(strTempDate) = False Then
MsgBox "Invalid date."
GoTo Leave:
End If
dteFlagDate = CDate(strTempDate)

Set objFields = objCDOContact.Fields
objFields.Add CdoPR_FLAG_STATUS, 2
objFields.Add CdoPR_REPLY_REQUESTED, True
objFields.Add CdoPR_RESPONSE_REQUESTED, True
objFields.Add CdoPR_FLAG_TEXT, 8, strValue, CdoPropSetID4
objFields.Add CdoPR_FLAG_DUE_BY, 7, dteFlagDate, CdoPropSetID4
objFields.Add CdoPR_FLAG_DUE_BY_NEXT, 7, dteFlagDate, CdoPropSetID4
objFields.Add CdoPR_REPLY_TIME, dteFlagDate
'**
objFields.Add CdoPR_REMINDER_SET, 11, True, CdoPropSetID4
objCDOContact.Update

Leave:
If Not objSession Is Nothing Then objSession.Logoff
If Not objNS Is Nothing Then objNS.Logoff
Set objSession = Nothing
Set objCDOContact = Nothing
Set objOLContact = Nothing
Set objNS = Nothing
Set objFields = Nothing
Set objField = Nothing
End Sub

 

[Eric Legault [MVP - Outlook]]

Hi Steve. You just need to wrap most of that code inside a loop that
iterates through the ActiveExplorer.Selection object:

For intX = 1 To ActiveExplorer.Selection.Count
Set objOLContact = Application.ActiveExplorer.Selection(intX)
Next