View Single Post
  #3  
Old May 22nd 06, 07:17 AM posted to microsoft.public.outlook.program_vba
Michael Bauer
external usenet poster
 
Posts: 435
Default Header from Outlook Rule

Am Sat, 20 May 2006 17:42:01 -0700 schrieb Steve A.:

If an object variable isnīt set then, of course, trying to access that
objectīs methods fails, too.

Because the message header contains e-mail addresses itīs blocked. A good
page that lists all infos about that is www.outlookcode.com/d/sec.htm

For getting the header without that dialog Iīd recommend the Redemption from
www.dimastr.com

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.vbOffice.net --


Michael thanks for your help.

There was another critical error in the code as well. The inclusion of

error
handling helped flush it out. The other error was a call to

objSession.Logoff

The code that works for me is show below. The only problem now being the
pop-up dialog "A program is trying to access e-mail addresses you have

stored
in outlook. Do you want to allow this?"

Regards Steve A

Code for retrieving internet headers in an Outlook Rule:

Function GetCDOItemFromOL(objOLItem As Object) As MAPI.Message
Dim objSession As MAPI.Session
Dim objApp As Outlook.Application
Dim strEntryID As String
Dim strStoreID As String

On Error GoTo eh

Set objApp = CreateObject("Outlook.Application")
strEntryID = objOLItem.EntryID
strStoreID = objOLItem.Parent.StoreID
Set objSession = CreateObject("MAPI.Session")
objSession.Logon , , False, False

Set GetCDOItemFromOL = objSession.GetMessage(strEntryID, strStoreID)

'objSession.Logoff == WAS AN ERROR
Set objSession = Nothing
Exit Function
eh:
If Err.Number 0 Then
MsgBox "Connection error: " & Err.Number & " " & Err.Description
Err.Clear
Exit Function
End If

End Function

Sub RuleScript(MyMail As MailItem)
Dim objCDOMsg As MAPI.Message
Dim InternetHeaders As String
Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
Set objCDOMsg = GetCDOItemFromOL(MyMail)
InternetHeaders = objCDOMsg.Fields(CdoPR_TRANSPORT_MESSAGE_HEADERS). Value
MsgBox "Mail message arrived Internet Headers Are : " & InternetHeaders
Set objCDOMsg = Nothing
End Sub

Ads