Unable to add "X-Header" to a mail that is being sent...

[gopi]

Environment:
-Outlook 2002(XP)
-Added references to "Microsoft Outlook 10.0 Object Library" & "Microsoft
CDO 1.21 Library"

I have written a VB project using MS Visual Basic 6.0. My intention is to
add a X-Header to a mail that is being sent from Outlook. I am capturing the
ItemSend event and trying to add the header in that event handler.

Please find the complete source code below.

Please note that the Sub ChangeHeader() is working absolutely fine if I call
it for an existing mail(with or without headers) in my Outlook Inbox.

But I have a problem in calling this ChangeHeader() from my ItemSend event
handler, as ChangeHeader() takes MAPI.Message as an argument, but
MyOLApp_ItemSend() is giving me Outlook.MailItem.

How do I convert Outlook.MailItem to MAPI.Message?
Or
Is there any other way to add the X-header without needing to have a
MAPI.Message object?

Thanks,
Gopi

************************************************************************


Public WithEvents MyOLApp As Outlook.Application

Sub Intialize_Event_Handlers()

Set MyOLApp = Application
MsgBox "Initialize Event Handlers successful"

End Sub



Private Sub Command1_Click()

Intialize_Event_Handlers

End Sub



Private Sub MyOLApp_ItemSend(ByVal Item As Object, Cancel As Boolean)

MsgBox "I am in ItemSend handler"

Dim myMailItem As Outlook.MailItem
Set myMailItem = Item

MsgBox myMailItem.Subject

'How do I now call ChangeHeader(), which takes MAPI.Message, as an
argument!!!
'Add the custom header now
'ChangeHeader oMessage


End Sub



Sub ChangeHeader(oMessage As MAPI.Message)

' Initalize error handling
On Error Resume Next

MsgBox "ChangeHeader - BEGIN", vbInformation

Dim oFields As MAPI.Fields
Set oFields = oMessage.Fields

Dim strheader As String

' Get SMTP header
Err.Clear
strheader = oFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value

If Err.Number = 0 Then
MsgBox strheader 'Display the original Internet headers

'Append the custom X-Header now!
oMessage.Fields(CdoPR_TRANSPORT_MESSAGE_HEADERS) =
oMessage.Fields(CdoPR_TRANSPORT_MESSAGE_HEADERS) & vbCrLf &

"X-MY-HEADER9: Hello"

ElseIf Err.Number = &H8004010F Then
Err.Clear
MsgBox "No SMTP message header information on this message",
vbInformation

'Add the custom X-Header now
oFields.Add CdoPR_TRANSPORT_MESSAGE_HEADERS, "X-MY-NEWHEADER: Hello"

Else
MsgBox "some vague scenario", vbInformation

End If


oMessage.Update

MsgBox "ChangeHeader - END", vbInformation

End Sub


************************************************************************

 

[Ken Slovak - [MVP - Outlook]]

Get the ID of the MAPI.Message and use NameSpace.GetItemFromID to get the
equivalent Outlook item. For the reverse get the Outlook item's EntryID and
use Session.GetMessage to get a CDO item.

Other than CDO or Extended MAPI or a MAPI wrapper like Redemption you can
only add x-headers without using a different API if you are using Outlook
2007 and use the PropertyAccessor object.

 

[gopi]

Thanks for the information.

I have followed your suggestion, but it did not work i.e. I am still not
able to add the header. Please find the complete code below.

Please let me know what is wrong witrh the following code.

thanks,
gopi

-------------------------------------------------------

Public WithEvents MyOLApp As Outlook.Application
Public WithEvents MyOLItems As Outlook.Items


Sub Intialize_Event_Handlers()

Set MyOLApp = Application
Set MyOLItems = Application.Session.GetDefaultFolder(olFolderInbox).Items

MsgBox "Initialize Event Handlers successful"

End Sub

Private Sub Command1_Click()
Intialize_Event_Handlers
End Sub

Private Sub MyOLApp_ItemSend(ByVal Item As Object, Cancel As Boolean)

'Initalize error handling
On Error Resume Next

MsgBox "I am in ItemSend handler"

Dim myMailItem As Outlook.MailItem
Set myMailItem = Item

MsgBox myMailItem.Subject

'myMailItem.Save

Dim oSession As MAPI.Session
Set oSession = New MAPI.Session
oSession.Logon

Dim strEntryID As String

Err.Clear
strEntryID = myMailItem.EntryID

If Err.Number <> 0 Then
MsgBox "EntryID could NOT be obtained"
Else
MsgBox "EntryID is obtained. It is"
MsgBox strEntryID
End If


Dim oMessage As Message
Set oMessage = oSession.GetMessage(strEntryID)

'Add the custom header now
ChangeHeader oMessage

'Get the MailItem from Message ID
Dim strID As String
strID = oMessage.ID
MsgBox strID

Dim olNamespace As NameSpace
Set olNamespace = MyOLApp.GetNamespace("MAPI")

Set myMailItem = olNamespace.GetItemFromID(strID)
'myMailItem.Send

End Sub

Sub ChangeHeader(oMessage As MAPI.Message)

' Initalize error handling
On Error Resume Next

MsgBox "ChangeHeader - BEGIN", vbInformation

Dim oFields As MAPI.Fields
Set oFields = oMessage.Fields

Dim strheader As String

' Get SMTP header
Err.Clear
strheader = oFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value

If Err.Number = 0 Then
MsgBox strheader 'Display the original Internet headers again

'Append the custom X-Header now!
oMessage.Fields(CdoPR_TRANSPORT_MESSAGE_HEADERS) =
oMessage.Fields(CdoPR_TRANSPORT_MESSAGE_HEADERS) & vbCrLf & "X-MY-HEADER9:
Hello"

ElseIf Err.Number = &H8004010F Then
Err.Clear
MsgBox "No SMTP message header information on this message",
vbInformation

'Add the custom X-Header now
oFields.Add CdoPR_TRANSPORT_MESSAGE_HEADERS, "X-MY-NEWHEADER: Hello"

Else
MsgBox "some vague scenario", vbInformation

End If


oMessage.Update

'MsgBox oMessage.Fields(&H7D001E) 'Display the UPDATED Internet headers

MsgBox "ChangeHeader - END", vbInformation

End Sub

 

[Ken Slovak - [MVP - Outlook]]

You cannot just try to find the message headers and append one to the
existing headers, it doesn't work that way. Plus the headers don't exist on
sent items, only on received items so what you are trying to do will never
work. You need to add a MAPI property to the item and MAPI will then turn
that into an x-header when the item goes out. You will only be able to see
the MAPI property you created on your end.

Here is some Redemption code that creates an x-header:

set sItem = CreateObject("Redemption.SafeMailItem")
sItem.Item = MailItem
tag = sItem.GetIDsFromNames("{00020386-0000-0000-C000-000000000046}",
"x-test-header")
tag = tag or &H1E 'the type is PT_STRING8
sItem.Fields(Tag) = "test value"
sItem.Subject = sItem.Subject 'to trick Outlook into thinking that
something has changed
sItem.Save

You would have to translate that from Redemption to CDO.

Also, for CDO you should be using a piggy-back logon and not a blank logon:
Logon "", "", False, False.

 

[gopi]

I have some success with what I was tring to do.
Complete code is provided after my signature.

I have a few questions though:

1)
a) Currently I am doing a MAPI.Session Logon in my macro
Intialize_MyEventHandlers() as follows:
Set oSession = New MAPI.Session
oSession.Logon

b) This MAPI.Session object is used later in my ItemSend event handler.

c) I want to avoid this second time Logon i.e. what I am doing in
Intialize_MyEventHandlers(), as the user is already logged in.

d)There is an Outlook.Application event called MAPILogonComplete, which is
triggered after the user logs on to Outlook.
Can I get the MAPI.Session object from within this MAPILogonComplete event
handler?
Or is there anyway I can avoid doing a oSession.Logon(), as it is asking the
user to logon, though he is already logged on.

2. My code is NOT working if WinWord is used as the editor to send the mail.
It is crashing when the control goes out of MyOLApp_ItemSend().

Can you please help me here?

3. I am having to do myMailItem.Save in MyOLApp_ItemSend(). Otherwise
EntryID will NOT be there. Or I have to do "Save" of the mail in Outlook
before "Send"ing it.
Is there anyway I can avoid doing a Save() here?

thanks,
gopi


--------------------------------------
Public WithEvents MyOLApp As Outlook.Application
Dim oSession As MAPI.Session

Sub Intialize_MyEventHandlers()
Set MyOLApp = Application

Set oSession = New MAPI.Session
oSession.Logon

MsgBox "Initialize Event Handlers successful"

End Sub


Private Sub Command1_Click()
Intialize_MyEventHandlers
End Sub

Private Sub MyOLApp_Quit()
MsgBox "I am in QUIT"
oSession.Logoff
Set oSession = Nothing
End Sub

Private Sub MyOLApp_ItemSend(ByVal Item As Object, Cancel As Boolean)

'Initalize error handling
On Error Resume Next

MsgBox "I am in ItemSend handler"

Dim myMailItem As Outlook.MailItem
Set myMailItem = Item

MsgBox myMailItem.Subject

myMailItem.Save 'Otherwise EntryID will NOT be there. Or "Save" before
"Send" from within OL itself!

Dim strEntryID As String

Err.Clear
strEntryID = myMailItem.EntryID

If Err.Number <> 0 Then
MsgBox "EntryID could NOT be obtained"
Else
MsgBox "EntryID is obtained. It is"
MsgBox strEntryID
End If

Dim oMessage As Message
Set oMessage = oSession.GetMessage(strEntryID)

'Add the custom header now
ChangeHeader oMessage

'Now cancel the send operation, as it is already sent in ChangeHeader()
Cancel = True

myMailItem.Close (olDiscard)
Set myMailItem = Nothing

End Sub

Sub ChangeHeader(oMessage As MAPI.Message)

' Initalize error handling
On Error Resume Next

MsgBox "ChangeHeader - BEGIN", vbInformation

Dim oFields As MAPI.Fields
Set oFields = oMessage.Fields

Dim strheader As String

' Get SMTP header
Err.Clear
strheader = oFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value

If Err.Number = 0 Then
MsgBox strheader 'Display the original Internet headers again

'Append the custom X-Header now!
oMessage.Fields(CdoPR_TRANSPORT_MESSAGE_HEADERS) =
oMessage.Fields(CdoPR_TRANSPORT_MESSAGE_HEADERS) & vbCrLf & "X-MY-HEADER9:
Hello"

ElseIf Err.Number = &H8004010F Then
Err.Clear
MsgBox "No SMTP message header information on this message",
vbInformation

'Add the custom X-Header now
oFields.Add CdoPR_TRANSPORT_MESSAGE_HEADERS, "X-MY-NEWHEADER: Hello"

Else
MsgBox "some vague scenario", vbInformation

End If


MsgBox oMessage.Fields(&H7D001E) 'Display the UPDATED Internet headers

oMessage.Update
oMessage.Send 'If I don't "Send" from here, the header is not getting
added!

MsgBox "ChangeHeader - END", vbInformation

End Sub