У меня нет «учетной записи электронной почты» ни в одном из моих представлений, и я не хочу менять ни одно из них, чтобы понять, что будет содержать этот столбец.Я подозреваю, что это не одно свойство, а зависит от контекста.
Я не понимаю, почему вы ожидаете, что свойство "SendUsingAccount" появится в полученном электронном письме.Если помощник отправит электронное письмо на имя менеджера, я ожидаю, что имя менеджера и адрес электронной почты появятся в свойствах отправителя.Я не ожидал бы найти имя помощника в любом месте.
Я использую Проводник для расследования электронных писем.Чтобы использовать Проводник, пользователь выбирает одно или несколько писем, а затем вызывает макрос, который обрабатывает выбранные письма.Макросы, которые я использую для исследований, либо выводят небольшое количество свойств в Immediate Window, либо каждое свойство, которое меня когда-либо интересовало, в файл рабочего стола.
Я привел в порядок свои процедуры, так что я могу включить обе версии без особых усилий.много повторений.
Примечание: эти подпрограммы нуждаются в ссылках на «Microsoft Scripting Runtime» и «Microsoft ActiveX Data Objects nn Library».Nn, вероятно, «6.1», но используйте любую версию, которая у вас есть.Если вы не понимаете «ссылки», спросите, и я объясню.
Макрос InvestigateEmails - это макрос, который вы вызываете после выбора одного или нескольких электронных писем, которые вы хотите исследовать.Внутри макроса есть оператор #Const Selected = True.Это инструктирует макрос вызывать макрос OutSomeProperties для выполнения вывода.Если вы измените оператор на #Const Selected = False, он будет вызывать макрос OutAllProperties.
Макрос OutSomeProperties выводит небольшое количество свойств в Immediate Window.
Макрос OutAllProperties выводит каждыйсвойство, которое меня когда-либо интересовало. В частности, оно включает весь заголовок сообщения.Если искомого значения нет в заголовке сообщения, оно недоступно для Outlook.
После этих макросов приведен ряд «стандартных» подпрограмм.Я держу эти стандартные процедуры в своих собственных модулях.Я считаю, что я всегда включал стандартную процедуру, вызываемую первыми тремя макросами.Если нет, вы получите сообщение об ошибке, в котором говорится, что xxxx не может быть найден.Сообщите об этой ошибке в комментарии, и я добавлю недостающую подпрограмму в мой ответ.
Запуск макроса InvestigateEmails как есть.Является ли значение, которое вы ищете, выводится в Immediate Window?Если нет, измените 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