Outlook VBA code for aborting ContactItem save

[dtrimble]

I'm fairly new to VBA, but I programmed extensively in Visual Basic many years ago. I'm familiar enough and comfortable enough with writing the code, but not yet fully familiar with Outlook's object model, collections, methods, etc.

What I'm trying to do is create a VBA script that will allow me to prompt the user (just me in this case) if a contact is being saved that has not been assigned at least one category. Let's just say I'm trying to forcibly impose better habits on my record-keeping :-)

Now, I'm approaching this with the code below. So far, it's not working. I'm having two problems:

1. My routine doesn't even seem to be firing. With the code in place in VBA, if I create a dummy new contact and try to save it, it saves as normally; my msgbox code below never fires.

2. Even if I could get that to work, the msgbox is supposed to prompt the user "are they sure they want to save without specifying any categories", and have a Yes and No button. If Yes, it should proceed with the save. But if the user hits no, I'm not clear how I would programmatically abort their saving of the contactitem.


Can anyone point me in the right direction here?

Dan


from Application_Startup...


Dim ns As Outlook.NameSpace

Set ns = Application.GetNamespace("MAPI")
Set myContacts = ns.GetDefaultFolder(olFolderContacts).Items



and the relevant ItemChange event...

Private Sub myContacts_ItemChange(ByVal Item As Object)

Dim msg As String

If TypeOf Item Is ContactItem Then
If Len(Item.Categories) = 0 Then
msg = "You are are attempting to save a contact without any assigned categories. Are you sure you wish to do this?"
If MsgBox(msg, vbYesNo + vbDefaultButton2 + vbQuestion, "Contact Categorization") = vbYes Then
Exit Sub
Else
MsgBox "Prohibit save here????", vbCritical
End If
Else
' already has a category
Exit Sub
End If
End If

End Sub

[JP2112]

How about allowing the end user (you) to set the categories?


Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Set Items = GetItems(GetNS(GetOutlookApp), olFolderContacts)
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim msg As String
Dim cItem As Outlook.ContactItem

If TypeOf Item Is ContactItem Then
Set cItem = Item
If Len(cItem.Categories) = 0 Then
msg = "You are are attempting to save a contact without any assigned categories. Are you sure you wish to do this?"
If MsgBox(msg, vbYesNo + vbDefaultButton2 + vbQuestion, "Contact Categorization") = vbNo Then
cItem.Delete
Else
With cItem
.ShowCategoriesDialog
.Save
End With
End If
End If
End If
End Sub