This example assumes that you have CDO installed.
With Microsoft Outlook 2000/2002 you need to add CDO 1.21 as custom installation option because they are not included in a typical install.
' Option Explicit Implements IDTExtensibility2 Dim WithEvents oApp As Outlook.Application Dim oSession As Object ' CDO MAPI session object '========================================================= Private Sub IDTExtensibility2_OnBeginShutdown(custom() As Variant) 'Use this subroutine when the host app is shutting down 'You should persist or destroy your objects in this subroutine On Error Resume Next oSession.Logoff Set oSession = Nothing Set oApp = Nothing End Sub '========================================================= Private Sub IDTExtensibility2_OnConnection(ByVal Application As Object, _ ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, _ ByVal AddInInst As Object, custom() As Variant) 'This subroutine is called when your Add-in is connected to 'by the host application On Error Resume Next Set oApp = Application 'Create CDO session Set oSession = oApp.CreateObject("MAPI.Session") 'use existing session oSession.Logon End Sub '========================================================= Private Sub IDTExtensibility2_OnAddInsUpdate(custom() As Variant) 'Use this subroutine when Add-ins are updated End Sub '========================================================= Private Sub IDTExtensibility2_OnDisconnection(ByVal RemoveMode _ As AddInDesignerObjects.ext_DisconnectMode, _ custom() As Variant) 'This sub is called when your add-in is disconnected from the host End Sub '========================================================= Private Sub IDTExtensibility2_OnStartupComplete(custom() As Variant) 'This sub is called when the host application has completed 'its startup routines End Sub '========================================================= Private Sub oApp_ItemSend(ByVal Item As Object, _ Cancel As Boolean) On Error Resume Next If TypeName(Item) = "MailItem" Then AddXHeader Item, "x-test1", "123456" ' cancel ItemSend event Cancel = True End If End Sub '========================================================= Private Sub AddXHeader(ByVal MailItem As Outlook.MailItem, _ Prop As String, Val As String) Dim oItem As Object Dim oField As Object ' Save mail item to get EntryID MailItem.Save ' Get CDO mail item Set oItem = oSession.GetMessage(MailItem.EntryID) 'Set oField = oItem.Fields.Add(Prop, vbString, Val, _ ' "0002038600000000C000000000000046") 'We have to change PropSetID, see MS KB 195656 ' Set oField = oItem.Fields.Add(Prop, vbString, Val, _ "8603020000000000C000000000000046") ' Save changes oItem.Update ' CDO send oItem.Send ' Cleanup Set oField = Nothing Set oItem = Nothing End SubI have tested this code with Outlook 2002 (10.4219.4219) SP2 and Exchange 2000 Server SP3.
As Outlook 2002 includes security features to prevent other programs from accessing your e-mail addresses or sending e-mail messages on your behalf, you will see the security warnings while this add-in is running.
If you are a standalone user, Outlook provides no way to suppress this behavior. However, you can redo the program using Redemption, a third-party COM library that wraps around Extended MAPI.
If you are the administrator in an Exchange Server environment, you can reduce the impact of the security prompts with administrative tools. See Administrative Options for the Outlook E-mail Security Update.
Feel free to send me your comments and criticism.