找不到该属性来分析此列表的所有元素（和子对象）： https://docs.microsoft.com/en-us/office/vba/api/outlook.mailitem.actions
某些属性值（例如大小或主体）可直接访问。 必须从存储的子对象中提取其他值（如收件人）。 但是，所有检索到的值都不对应于Outlook列中的可见数据。
我想，存储在字段/列“ e-mail-account”中的数据是在从属性“ SendUsingAccount”发送时插入的，但是此属性似乎无法在收到的电子邮件中访问。
如何在收到的电子邮件中访问/编辑此属性？
...All Mail Fields/E-Mail account
由于此描述，我本来以为“ SendUsingAccount”可能是数据源：“ ...返回或设置一个Account对象，该对象表示要在其中发送MailItem的帐户。读/写...” But now I know, the string comes from here, when a new account is created (there may be other ways)
答案 0 :(得分：0)
我在任何视图中都没有“电子邮件帐户”，并且我不想更改其中的任何一个以了解此列将包含的内容。我怀疑这不是单个属性，而是取决于上下文的。
我不明白您为什么希望属性“ SendUsingAccount”出现在收到的电子邮件中。如果助理以经理的名义发送电子邮件，我希望经理的姓名和电子邮件地址出现在发件人属性中。我不会在任何地方找到助理的名字。
我使用资源管理器调查电子邮件。要使用资源管理器，用户选择一个或多个电子邮件，然后调用一个处理选定电子邮件的宏。我用于调查的宏会将少量属性输出到“即时窗口”，或者将我曾经感兴趣的每个属性输出到桌面文件。
我整理了例程，以便可以包含两个版本而无需过多重复。
注意：这些例程需要引用“ Microsoft脚本运行时”和“ Microsoft ActiveX数据对象n.n库”。 n.n可能是“ 6.1”，但请使用您拥有的任何版本。如果您不理解“参考”，请询问，我会解释。
宏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://stackoverflow.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://stackoverflow.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 StackOverflow
' 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://stackoverflow.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
答案 1 :(得分：0)
您可以使用MailItem.PropertyAccessor.GetProperty（）访问该属性，该属性指定OutlookSpy – Dmitry Streblechenko显示的DASL名称
MailItem.PropertyAccessor.GetProperty（“ schemas.microsoft.com/mapi/id{00062008-0000-0000-C000-000000000046}/8580001F”）