Get contect ID over CDO

[Tora]

Hi all,

I have here Outlook XP / 2003 and 2007. I must check some emails for
embedded images. I have found a example code to get the cid over cdo but
it work not completly.

I have the message id from the selected message but I become no resoltes
from the GetMessage.

Can me help someone please. Big big thanks for help.

Best regards,

Tora

Sub check_CID_with_CDO()
Dim itm As Object
Dim objSMail As MAPI.Message
Dim objSAtt As MAPI.Attachment
Dim Obj As Object
Dim objSession As MAPI.Session
Dim strCID As String
On Error Resume Next

Set objSession = CreateObject("MAPI.Session")
objSession.Logon , , False, False
Set itm = GetCurrentItem()
If itm.Class = olMail Then
Set objSMail = CreateObject("MAPI.Message")
strEntryID = itm.EntryID


' <<<---- The object OMsg is empty after 'GetMessage'. Why?????
Set oMsg = objSession.GetMessage(strEntryID)


For Each objSAtt In oMsg.Attachments
' Get the content-ID for the attachment,
' if present. Thanks to Dmitry Streblechenko,
' author of Redemption, for the proptag.
' x3712001f for RTF ????
strCID = objSAtt.Fields(&H3712001E)
If strCID = "" Then
MsgBox "Content-id is Empty, so attachment is not embedded..."
Else
MsgBox "Content-id = " & strCID & _
" So it is embedded..."
End If
strCID = ""
Next
End If

Set objSAtt = Nothing
Set itm = Nothing
End Sub


Function GetCurrentItem() As Object
Dim objApp As Outlook.Application

Set objApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
Case Else
' anything else will result in an error, which is
' why we have the error handler above
End Select

Set objApp = Nothing
End Function

[Ken Slovak - [MVP - Outlook]]

If the item is a new item and has never been saved there will be no EntryID
property. Could that be the case here?

Try stepping the code and in the GetCurrentItem() procedure see if the
returned item has an EntryID property. If there is an EntryID see if
supplying the StoreID property helps.
--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Professional Programming Outlook 2007.
Reminder Manager, Extended Reminders, Attachment Options.
http://www.slovaktech.com/products.htm

Post by Tora
Hi all,
I have here Outlook XP / 2003 and 2007. I must check some emails for
embedded images. I have found a example code to get the cid over cdo but
it work not completly.
I have the message id from the selected message but I become no resoltes
from the GetMessage.
Can me help someone please. Big big thanks for help.
Best regards,
Tora
Sub check_CID_with_CDO()
Dim itm As Object
Dim objSMail As MAPI.Message
Dim objSAtt As MAPI.Attachment
Dim Obj As Object
Dim objSession As MAPI.Session
Dim strCID As String
On Error Resume Next
Set objSession = CreateObject("MAPI.Session")
objSession.Logon , , False, False
Set itm = GetCurrentItem()
If itm.Class = olMail Then
Set objSMail = CreateObject("MAPI.Message")
strEntryID = itm.EntryID
' <<<---- The object OMsg is empty after 'GetMessage'. Why?????
Set oMsg = objSession.GetMessage(strEntryID)
For Each objSAtt In oMsg.Attachments
' Get the content-ID for the attachment,
' if present. Thanks to Dmitry Streblechenko,
' author of Redemption, for the proptag.
' x3712001f for RTF ????
strCID = objSAtt.Fields(&H3712001E)
If strCID = "" Then
MsgBox "Content-id is Empty, so attachment is not embedded..."
Else
MsgBox "Content-id = " & strCID & _
" So it is embedded..."
End If
strCID = ""
Next
End If
Set objSAtt = Nothing
Set itm = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
Case Else
' anything else will result in an error, which is
' why we have the error handler above
End Select
Set objApp = Nothing
End Function

[HOOVERJeannette21]

Following my investigation, billions of persons all over the world receive
the <a href="http://bestfinance-blog.com/topics/business-loans">business
loans</a> at good creditors. So, there's a good possibility to find a
college loan in any country.