Код ниже нуждается в ссылках.Родной VBA ограничен;он ничего не знает о MailItems, рабочих листах, документах, таблицах или любых других объектах, используемых продуктом Office.
В редакторе Outlook VBA нажмите «Инструменты», а затем «Ссылки».Длинный список библиотек будет отображаться с несколькими помеченными вверху.Эти отмеченные библиотеки будут включать «Библиотеку объектов Microsoft Library nn.0».Значение для «nn» будет зависеть от версии Outlook, которую вы используете.Именно эта библиотека сообщает VBA о папках и MailItems и всех других объектах Outlook.
Приведенный ниже код нуждается в ссылках на «Среду выполнения сценариев Microsoft» и «Объекты данных Microsoft ActiveX в библиотеке».В моей системе «nn» - это «6.1».Если эти библиотеки не отмечены, прокрутите список вниз, пока не найдете их, и отметьте их.Когда вы в следующий раз нажмете «Ссылки», эти библиотеки окажутся в начале списка.
Вы говорите, что электронные письма, которые вам нужно обработать, имеют одинаковый формат.Вы говорите, что нужные вам данные хранятся в виде таблицы.Вы имеете в виду таблицу HTML или текстовую таблицу с пробелами без пробелов для выравнивания столбцов?Таблицы могут выглядеть одинаково, но форматироваться по-разному.Код ниже - это процедура, которую я использую, когда мне нужно выяснить точный формат одного или двух писем.Ответ, на который я ссылался выше, включает в себя процедуру, которую я использую, если я хочу исследовать большое количество писем.
Чтобы использовать процедуру, указанную ниже, вставьте новый модуль без Outlook и скопируйте в него код ниже.Выберите один или два письма, которые вы хотите обработать, а затем наберите InvestigateEmails().Он создаст файл на вашем рабочем столе с именем «InvestigateEmails.txt», который будет содержать несколько свойств выбранных писем.В частности, он будет содержать текст и HTML-тела.Управляющие символы CR, LF и TB будут заменены строками, но в противном случае эти тела будут такими, какими они выглядят в макросе VBA.Вы не можете извлечь адреса электронной почты назначения из доступного тела или тел, не зная, как они выглядят для макроса VBA.
Я сказал, что это обычная процедура, которую я использую для исследования одного или двух писем.Это не вся правда.Моя программа выводит еще много свойств, но я удалил все, кроме тех, которые, как я думал, будут полезны для вас.Я могу добавить больше свойств, если я пропустил то, что вам нужно.
Option Explicit
Public Sub InvestigateEmails()
' Outputs properties of selected emails to a file.
' ??????? No record of when originally coded
' 22Oct16 Output to desktop file rather than Immediate Window.
' 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 FileBody As String
Dim Fso As FileSystemObject
Dim ItemCrnt As MailItem
Dim Path As String
Path = CreateObject("WScript.Shell").specialfolders("Desktop")
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Pleaase select one or more emails then try again", vbOKOnly)
Exit Sub
Else
FileBody = ""
For Each ItemCrnt In Exp.Selection
With ItemCrnt
FileBody = FileBody & "From (Sender): " & .Sender & vbLf
FileBody = FileBody & "From (Sender name): " & .SenderName & vbLf
FileBody = FileBody & "From (Sender email address): " & _
.SenderEmailAddress & vbLf
FileBody = FileBody & "Subject: " & CStr(.Subject) & vbLf
Call OutLongText(FileBody, "Text: ", Replace(Replace(Replace(.Body, vbLf, _
"{lf}" & vbLf), vbCr, "{cr}"), vbTab, "{tb}"))
Call OutLongText(FileBody, "Html: ", Replace(Replace(Replace(.HtmlBody, vbLf, _
"{lf}" & vbLf), vbCr, "{cr}"), vbTab, "{tb}"))
FileBody = FileBody & "--------------------------" & vbLf
End With
Next
End If
Call PutTextFileUtf8NoBOM(Path & "\InvestigateEmails.txt", FileBody)
End Sub
Public Sub OutLongText(ByRef FileBody As String, ByVal Head As String, _
ByVal Text As String)
Dim PosEnd As Long
Dim LenOut As Long
Dim PosStart As Long
If Text <> "" Then
PosStart = 1
Do While PosStart <= Len(Text)
PosEnd = InStr(PosStart, Text, vbLf)
If PosEnd = 0 Or PosEnd > PosStart + 100 Then
' No LF in remainder of text or next 100 characters
PosEnd = PosStart + 99
LenOut = 100
Else
' Output upto LF. Restart output after LF
LenOut = PosEnd - PosStart
PosEnd = PosEnd
End If
If PosStart = 1 Then
FileBody = FileBody & Head
Else
FileBody = FileBody & Space(Len(Head))
End If
FileBody = FileBody & Mid$(Text, PosStart, LenOut) & vbLf
PosStart = PosEnd + 1
Loop
End If
End Sub
Public 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