在 Outlook 对象模型中哪里可以找到 mailitem 对象的属性值“电子邮件帐户”？
Posted
技术标签:
【中文标题】在 Outlook 对象模型中哪里可以找到 mailitem 对象的属性值“电子邮件帐户”？【英文标题】：Where to find property value "e-mail-account" of mailitem-objects in outlook object-model? 【发布时间】：2019-04-16 15:40:15 【问题描述】：在分析此列表（和子对象）的所有元素时找不到该属性： https://docs.microsoft.com/en-us/office/vba/api/outlook.mailitem.actions
某些属性值（如大小或正文）可以直接访问。 其他值（如收件人）必须从存储的子对象中提取。 但是所有检索到的值都与outlook-column中的可见数据不对应。
这不是用户属性。 可以通过字段列表将该列插入到 outllok 电子邮件表视图中。我想，存储在“电子邮件帐户”字段/列中的数据是在从“SendUsingAccount”属性发送时插入的，但在收到的电子邮件中似乎无法访问此属性。
如何在收到的电子邮件中访问/编辑此属性？
Field Chooser/...
...All Mail Fields/E-Mail account
Where else to search?
由于这个描述，我最初认为“SendUsingAccount”可能是数据源：“...返回或设置一个代表要发送 MailItem 的帐户的帐户对象。读/写...” But now I know, the string comes from here, when a new account is created (there may be other ways)
【问题讨论】：
如果您转到 Outlook VBA 编辑器并单击 F2，您将获得所有类的列表。向下滚动左侧的列表，直到到达MailItem。右侧将列出MailItem 的大部分属性、方法和事件。你知道Recipients。不同版本的发件人在Sender、SenderName 和SenderEmailAddress。这就是你所追求的吗？
SendUsingAccount 这样助理就可以以其经理的名义发送电子邮件。
@TonyDallimore 否。该值似乎未存储在发件人 AddressEntry-Object 中。我编辑了我的帖子。也许它有助于澄清我正在寻找的价值。 SendUsingAccount 仍然是我无法访问的唯一属性。
您正在处理的场景是什么？ MailItem.SendUsingAccount 属性有什么问题？它将在收到的消息中填充。
@DmitryStreblechenko 我在一个没有账户的系统上有来自多个账户的 55k 封电子邮件。我必须评估它们并且需要访问字段/列“电子邮件帐户”的值。每封电子邮件都有这些信息，甚至在从 msg 文件导出和重新导入后会保留下来。一定有办法访问它……对吧？
【参考方案1】：
您可以使用 MailItem.PropertyAccessor.GetProperty() 访问该属性，指定 OutlookSpy 显示的 DASL 名称 – Dmitry Streblechenko
MailItem.PropertyAccessor.GetProperty("schemas.microsoft.com/mapi/id00062008-0000-0000-C000-000000000046/8580001F")
【讨论】：
刚试过，但参数无效...【参考方案2】：我的任何视图中都没有“电子邮件帐户”，并且我不希望更改任何视图以了解本专栏将包含的内容。我怀疑它不是单一属性，而是取决于上下文的属性。
我不明白您为什么希望属性“SendUsingAccount”出现在收到的电子邮件中。如果助理以经理的名义发送电子邮件，我希望经理的姓名和电子邮件地址出现在发件人属性中。我不希望在任何地方都能找到助理的名字。
我使用 Explorer 来调查电子邮件。要使用 Explorer，用户选择一封或多封电子邮件，然后调用处理所选电子邮件的宏。我用于调查的宏要么将少量属性输出到即时窗口，要么将我曾经感兴趣的每个属性输出到桌面文件。
我已经整理了我的例程，所以我可以包含两个版本而不会产生太多重复。
注意：这些例程需要参考“Microsoft Scripting Runtime”和“Microsoft ActiveX Data Objects n.n Library”。 n.n 可能是“6.1”，但请使用您拥有的任何版本。如果您不理解“参考”，请询问，我会解释。
Macro InvestigateEmails 是您在选择要调查的一封或多封电子邮件后调用的宏。在宏中是语句#Const Selected = True。这指示宏调用宏OutSomeProperties 来执行输出。如果将语句更改为#Const Selected = False，它将调用宏OutAllProperties。
宏OutSomeProperties 将少量属性输出到即时窗口。
宏OutAllProperties 输出我曾经感兴趣的每个属性。特别是，它包括整个消息头。如果您查找的值不在邮件标头中，则它对 Outlook 不可用。
在这些宏之后是一些“标准”例程。我将这些标准例程保存在它们自己的模块中。我相信我已经包含了前三个宏调用的标准例程。如果我没有，您将收到一条错误消息，告诉您无法找到 xxxx。在评论中报告此错误，我会将缺少的例程添加到我的答案中。
按原样运行宏 InvestigateEmails。您寻求的值是否输出到即时窗口？如果不是，请修改InvestigateEmails 以调用OutputAllProperties。查看“PR_TRANSPORT_MESSAGE_HEADERS”下的文本。你在这里寻求的价值是什么？如果是，请在评论中报告相关行，我将帮助您提取所需的属性。
Option Explicit
Public Sub InvestigateEmails()
' Outputs all or selected properties of one or more emails.
' To use:
' * Set "Selected" to True or False as required.
' * If Selected=True, review OutSomeProperties to ensure it
' outputs the properties of interest.
' * If Selected=False, review OutAllProperties to ensure it
' outputs the properties of interest.
' * Select one or more emails from a folder.
' * Run this subroutine.
' ========================================================================
' "Selected = True" to output a small number of properties for
' a small number of emails to the Immediate Window.
' "Selected = False" to output all properties for any number of emails
' to desktop file "InvestigateEmails.txt".
#Const Selected = True
' ========================================================================
' Technique for locating desktop from answer by Kyle:
' http://***.com/a/17551579/973283
' Needs reference to "Microsoft Scripting Runtime"
Dim Exp As Explorer
Dim ItemCrnt As MailItem
#If Not Selected Then
Dim FileBody As String
Dim fso As FileSystemObject
Dim Path As String
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop")
#End If
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Please select one or more emails then try again", vbOKOnly)
Exit Sub
Else
For Each ItemCrnt In Exp.Selection
If ItemCrnt.Class = olMail Then
#If Selected Then
Call OutSomeProperties(ItemCrnt)
#Else
Call OutAllProperties(ItemCrnt, FileBody)
#End If
End If
Next
End If
#If Not Selected Then
Call PutTextFileUtf8NoBom(Path & "\InvestigateEmails.txt", FileBody)
#End If
End Sub
Sub OutSomeProperties(ItemCrnt As Outlook.MailItem)
' Outputs selected properties of a MailItem to the Immediate Window.
' The Immediate Window can only display about 200 rows before the older
' rows start scrolling off the top. This means this routine is only
' suitable for displaying a small number of simple properties. Add or
' remove properties as necessary to meet the current requirement.
Dim InxR As Long
Debug.Print "=============================================="
Debug.Print " Profile: " & Session.CurrentProfileName
Debug.Print " User: " & Session.CurrentUser
With ItemCrnt
Debug.Print " Created: " & .CreationTime
Debug.Print " Receiver: " & .ReceivedByName
Debug.Print " Received: " & .ReceivedTime
For InxR = 1 To .Recipients.Count
Debug.Print "Recipient: " & .Recipients(InxR)
Next
Debug.Print " Sender: " & .Sender
Debug.Print " SenderEA: " & .SenderEmailAddress
Debug.Print " SenderNm: " & .SenderName
Debug.Print " SentOn: " & .SentOn
Debug.Print " Subject: " & .Subject
Debug.Print " To: " & .To
End With
End Sub
Sub OutAllProperties(ItemCrnt As Outlook.MailItem, ByRef FileBody As String)
' Adds all properties of a MailItem to FileBody.
' The phrase "all properties" should more correctly be "all properties
' that I know of and have ever been interested in".
' Source of PropertyAccessor information:
' https://www.slipstick.com/developer/read-mapi-properties-exposed-outlooks-object-model/
' 17Apr19 Created by combining a number of earlier routine which output
' different sets of properties to a file
Dim InxA As Long
Dim InxR As Long
Dim PropAccess As Outlook.propertyAccessor
If FileBody <> "" Then
FileBody = FileBody & String(80, "=") & vbLf
End If
With ItemCrnt
FileBody = FileBody & "From (Sender): " & .Sender
FileBody = FileBody & vbLf & "From (Sender name): " & .SenderName
FileBody = FileBody & vbLf & "From (Sender email address): " & _
.SenderEmailAddress
FileBody = FileBody & vbLf & "Subject: " & CStr(.Subject)
FileBody = FileBody & vbLf & "Received: " & Format(.ReceivedTime, "dmmmyy hh:mm:ss")
FileBody = FileBody & vbLf & "To: " & .To
FileBody = FileBody & vbLf & "CC: " & .CC
FileBody = FileBody & vbLf & "BCC: " & .BCC
If .Attachments.Count = 0 Then
FileBody = FileBody & vbLf & "No attachments"
Else
FileBody = FileBody & vbLf & "Attachments:"
FileBody = FileBody & vbLf & "No.|Type|Path|Filename|DisplayName|"
For InxR = 1 To .Recipients.Count
FileBody = FileBody & vbLf & "Recipient" & InxR & ": " & .Recipients(InxR)
Next
For InxA = 1 To .Attachments.Count
With .Attachments(InxA)
FileBody = FileBody & vbLf & InxA & "|"
Select Case .Type
Case olByValue
FileBody = FileBody & "Val"
Case olEmbeddeditem
FileBody = FileBody & "Ebd"
Case olByReference
FileBody = FileBody & "Ref"
Case olOLE
FileBody = FileBody & "OLE"
Case Else
FileBody = FileBody & "Unk"
End Select
' Not all types have all properties. This code handles
' those missing properties of which I am aware. However,
' I have never found an attachment of type Reference or OLE.
' Additional code may be required for them.
Select Case .Type
Case olEmbeddeditem
FileBody = FileBody & "|"
Case Else
FileBody = FileBody & "|" & .Pathname
End Select
FileBody = FileBody & "|" & .Filename
FileBody = FileBody & "|" & .DisplayName & "|"
End With
Next
End If ' .Attachments.Count = 0
Call OutLongTextRtn(FileBody, "Text: ", .Body)
Call OutLongTextRtn(FileBody, "html: ", .HtmlBody)
Set PropAccess = .propertyAccessor
FileBody = FileBody & vbLf & "PR_RECEIVED_BY_NAME: " & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0040001E")
FileBody = FileBody & vbLf & "PR_SENT_REPRESENTING_NAME: " & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0042001E")
FileBody = FileBody & vbLf & "PR_REPLY_RECIPIENT_NAMES: " & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0050001E")
FileBody = FileBody & vbLf & "PR_SENT_REPRESENTING_EMAIL_ADDRESS: " & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0065001E")
FileBody = FileBody & vbLf & "PR_RECEIVED_BY_EMAIL_ADDRESS: " & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0076001E")
FileBody = FileBody & vbLf & "PR_TRANSPORT_MESSAGE_HEADERS:" & vbLf & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E")
FileBody = FileBody & vbLf & "PR_SENDER_NAME: " & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1A001E")
FileBody = FileBody & vbLf & "PR_SENDER_EMAIL_ADDRESS: " & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E")
FileBody = FileBody & vbLf & "PR_DISPLAY_BCC: " & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E02001E")
FileBody = FileBody & vbLf & "PR_DISPLAY_CC: " & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E03001E")
FileBody = FileBody & vbLf & "PR_DISPLAY_TO: " & _
PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E")
Set PropAccess = Nothing
End With
End Sub
Sub OutLongTextRtn(ByRef TextOut As String, ByVal Head As String, _
ByVal TextIn As String)
' * Break TextIn into lines of not more than 100 characters
' and append to TextOut.
' * The output is arranged so:
' xxxx|sssssssssssssss|
' |sssssssssssssss|
' |ssssssssss|
' where "xxxx" is the value of Head and "ssss..." are characters from
' TextIn. The third line in the example could be shorter because:
' * it contains the last few characters of TextIn
' * there a linefeed in TextIn
' * a <xxx> string recording whitespace would have been split
' across two lines.
' 15Jan19 Added "|" at start and end of lines to make it clearer if
' whitespace added by this routine or was in original TextIn
' 3Feb19 Discovered I had two versions of OutLongText. Renamed this version to
' indicate it returned a formatted string.
' 4Feb19 Previous version relied on the caller tidying text for display. This
' version expects TextIn to be untidied and uses TidyTextForDspl to tidy
' the text and then creates TextOut from its output.
If TextIn = "" Then
' Nothing to do
Exit Sub
End If
Const LenLineMax As Long = 100
Dim PosBrktEnd As Long ' Last > before PosEnd
Dim PosBrktStart As Long ' Last < before PosEnd
Dim PosNext As Long ' Start of block to be output after current block
Dim PosStart As Long ' First character of TextIn not yet output
TextIn = TidyTextForDspl(TextIn)
TextIn = Replace(TextIn, "lf›", "lf›" & vbLf)
PosStart = 1
Do While True
PosNext = InStr(PosStart, TextIn, vbLf)
If PosNext = 0 Then
' No LF in [Remaining] TextIn
'Debug.Assert False
PosNext = Len(TextIn) + 1
End If
If PosNext - PosStart > LenLineMax Then
PosNext = PosStart + LenLineMax
End If
' Check for <xxx> being split across lines
PosBrktStart = InStrRev(TextIn, "‹", PosNext - 1)
PosBrktEnd = InStrRev(TextIn, "›", PosNext - 1)
If PosBrktStart < PosStart And PosBrktEnd < PosStart Then
' No <xxx> within text to be displayed
' No change to PosNext
'Debug.Assert False
ElseIf PosBrktStart > 0 And PosBrktEnd > 0 And PosBrktEnd > PosBrktStart Then
' Last or only <xxx> totally within text to be displayed
' No change to PosNext
'Debug.Assert False
ElseIf PosBrktStart > 0 And _
(PosBrktEnd = 0 Or (PosBrktEnd > 0 And PosBrktEnd < PosBrktStart)) Then
' Last or only <xxx> will be split across rows
'Debug.Assert False
PosNext = PosBrktStart
Else
' Are there other combinations?
Debug.Assert False
End If
'Debug.Assert Right$(Mid$(TextIn, PosStart, PosNext - PosStart), 1) <> "‹"
If TextOut <> "" Then
TextOut = TextOut & vbLf
End If
If PosStart = 1 Then
TextOut = TextOut & Head & "|"
Else
TextOut = TextOut & Space(Len(Head)) & "|"
End If
TextOut = TextOut & Mid$(TextIn, PosStart, PosNext - PosStart) & "|"
PosStart = PosNext
If Mid$(TextIn, PosStart, 1) = vbLf Then
PosStart = PosStart + 1
End If
If PosStart > Len(TextIn) Then
Exit Do
End If
Loop
End Sub
Sub PutTextFileUtf8NoBom(ByVal PathFileName As String, ByVal FileBody As String)
' Outputs FileBody as a text file named PathFileName using
' UTF-8 encoding without leading BOM
' Needs reference to "Microsoft ActiveX Data Objects n.n Library"
' Addition to original code says version 2.5. Tested with version 6.1.
' 1Nov16 Copied from http://***.com/a/4461250/973283
' but replaced literals with parameters.
' 15Aug17 Discovered routine was adding an LF to the end of the file.
' Added code to discard that LF.
' 11Oct17 Posted to ***
' 9Aug18 Comment from rellampec suggested removal of adWriteLine from
' WriteTest statement would avoid adding LF.
' 30Sep18 Amended routine to remove adWriteLine from WriteTest statement
' and code to remove LF from file. Successfully tested new version.
' References: http://***.com/a/4461250/973283
' https://www.w3schools.com/asp/ado_ref_stream.asp
Dim BinaryStream As Object
Dim UTFStream As Object
Set UTFStream = CreateObject("adodb.stream")
UTFStream.Type = adTypeText
UTFStream.Mode = adModeReadWrite
UTFStream.Charset = "UTF-8"
UTFStream.Open
UTFStream.WriteText FileBody
UTFStream.Position = 3 'skip BOM
Set BinaryStream = CreateObject("adodb.stream")
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
UTFStream.CopyTo BinaryStream
UTFStream.Flush
UTFStream.Close
Set UTFStream = Nothing
BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
BinaryStream.Flush
BinaryStream.Close
Set BinaryStream = Nothing
End Sub
Function TidyTextForDspl(ByVal Text As String) As String
' Tidy Text for dsplay by replacing white space with visible strings:
' Leave single space unchanged
' Replace single LF by ‹lf›
' Replace single CR by ‹cr›
' Replace single TB by ‹tb›
' Replace single non-break space by ‹nbs›
' Replace single CRLF by ‹crlf›
' Replace multiple spaces by ‹n s› where n is number of repeats
' Replace multiple LFs by ‹n lf› of white space character
' Replace multiple CRs by ‹cr› or ‹n cr›
' Replace multiple TBs by ‹n tb›
' Replace multiple non-break spaces by ‹n nbs›
' Replace multiple CRLFs by ‹n crlf›
' 15Mar16 Coded
' 3Feb19 Replaced "" (\x7B) and "" (\x7D) by "‹" (\u2039) and "›" (\u203A)
' on the grounds that the angle quotation marks were not likely to
' appear in text to be displayed.
' 5Feb19 Add code to treat CRLF as unit
' 28Mar19 Code to calculate PosWsChar after "<x>...<x>" converted to "<n x>"
' incorrect if "<x>...<x>" at the start of the string. Unlikely it
' was correct in other situations but this did not matter since the
' calculated value would be before the next occurrence of "<x>...<x>".
' But, if the string was near the beginning of the string, the
' calculated value was negative and the code crashed.
Dim InsStr As String
Dim InxWsChar As Long
Dim NumWsChar As Long
Dim PosWsChar As Long
Dim RetnVal As String
Dim WsCharCrnt As Variant
Dim WsCharValue As Variant
Dim WsCharDspl As Variant
WsCharValue = VBA.Array(" ", vbCr & vbLf, vbLf, vbCr, vbTab, Chr(160))
WsCharDspl = VBA.Array("s", "crlf", "lf", "cr", "tb", "nbs")
RetnVal = Text
' Replace each whitespace individually
For InxWsChar = 0 To UBound(WsCharValue)
RetnVal = Replace(RetnVal, WsCharValue(InxWsChar), "‹" & WsCharDspl(InxWsChar) & "›")
Next
' Look for repeats. If found replace <x> by <n x>
For InxWsChar = 0 To UBound(WsCharValue)
'Debug.Assert InxWsChar <> 1
PosWsChar = 1
Do While True
InsStr = "‹" & WsCharDspl(InxWsChar) & "›"
PosWsChar = InStr(PosWsChar, RetnVal, InsStr & InsStr)
If PosWsChar = 0 Then
' No [more] repeats of this <x>
Exit Do
End If
' Have <x><x>. Count number of extra <x>x
NumWsChar = 2
Do While Mid(RetnVal, PosWsChar + NumWsChar * Len(InsStr), Len(InsStr)) = InsStr
NumWsChar = NumWsChar + 1
Loop
RetnVal = Mid(RetnVal, 1, PosWsChar - 1) & _
"‹" & NumWsChar & " " & WsCharDspl(InxWsChar) & "›" & _
Mid(RetnVal, PosWsChar + NumWsChar * Len(InsStr))
PosWsChar = PosWsChar + Len(InsStr) + Len(NumWsChar)
Loop
Next
' Restore any single spaces
RetnVal = Replace(RetnVal, "‹" & WsCharDspl(0) & "›", " ")
TidyTextForDspl = RetnVal
End Function
【讨论】：
@ToniDallimore 感谢您的支持和您的代码。我设法在“OutAllProperties”模式下运行您的代码。它工作正常，但我无法在您的代码创建的“InvestigateEmails.txt”文件中找到该字符串。它会在接收时由 Outlook 插入到电子邮件中，表示“通过电子邮件帐户接收”而不是“通过电子邮件帐户发送”。它现在存储在 Outlook-Mailitem 中的某个位置，但它不是 sendet 电子邮件（和邮件标题）的一部分。 我了解机密性问题，但您能说明一下这个值是什么。如果该值不在消息头中，则它不在传入消息中。 Outlook 可以链接电子邮件并从这些链接中推断信息。这可能是来源吗？ @ToniDallimore 现在似乎可以确定它是下载帐户的名称，并且在接收电子邮件时由 Outlook 添加。它可以让我确定每封电子邮件最初是使用哪个帐户接收的。To 和 Recipients 不同。完整的标头包括消息通过的地址的历史记录。即使在其他地方更新，我也看不到消息头中不能出现这样的值。
我有两个主要的电子邮件帐户。如果我将一封电子邮件从一个移动到另一个，原始收件人仍会在标题中标识。我找不到因搬迁而发生变化的房产。在您的系统上，用于从服务器下载电子邮件的电子邮件地址是否可以与发送电子邮件的地址不同？我是家庭用户。如果您是企业用户，您可能拥有我一无所知且无权访问的功能。以上是关于在 Outlook 对象模型中哪里可以找到 mailitem 对象的属性值“电子邮件帐户”？的主要内容，如果未能解决你的问题，请参考以下文章