Извлечь текст сообщения Outlook с помощью VBA из Excel

Question

У меня есть огромное количество файлов Outlook .msg и Outlook .eml, сохраненных в общей сетевой папке (то есть вне Outlook). Я пытаюсь написать несколько VBA в Excel, который извлекает Субъекты, Sender, CC, приемник, SentTime, SentDate, текст сообщения из каждого файла и импортировать эти данные в ячейки Excel стройных

Темы Отправителя CC Приемник SentTime SentDate

Re: .. Майк Джейн Том 12:00:00 23 янв 2013

Я сделал аналогичную вещь с текстовыми документами, но я изо всех сил пытаюсь «получить» текст в файлах .msg.

До сих пор у меня есть код ниже. Мне нравится думать, что я нахожусь на верном пути, по крайней мере, но я застрял в строке, где я пытаюсь настроить ссылку на файл msg. Любые советы будут оценены ...

Dim MyOutlook As Outlook.Application 
Dim MyMail As Outlook.MailItem 

Set MyOutlook = New Outlook.Application 


Set MyMail = 

Dim FileContents As String 

FileContents = MyMail.Body 

С уважением

Answer 1

Предполагая, что вы знаете, или может вычислить полное имя файла & путь для .msg:

Dim fName as String 
fName = "C:\example email.msg" 

Set MyMail = MyOutlook.CreateItemFromTemplate(fName)` 

Answer 2

, так что я был в состоянии чтобы он работал с файлами .msg, сохраненными вне перспективы. Однако, поскольку у меня нет доступа к Outlook Express, у меня нет способа сохранить какие-либо файлы .eml на данный момент. Вот Sub Я придумал, что вставит тема, отправитель, CC, To и SendOn в таблицу первенствовать, начиная со строки 2 столбца 1 (предполагается, что строка заголовка в строке 1):

Sub GetMailInfo(Path As String) 

    Dim MyOutlook As Outlook.Application 
    Dim msg As Outlook.MailItem 
    Dim x As Namespace 

    Set MyOutlook = New Outlook.Application 
    Set x = MyOutlook.GetNamespace("MAPI") 

    FileList = GetFileList(Path + "*.msg") 


    row = 1 

    While row <= UBound(FileList) 

     Set msg = x.OpenSharedItem(Path + FileList(row)) 

     Cells(row + 1, 1) = msg.Subject 
     Cells(row + 1, 2) = msg.Sender 
     Cells(row + 1, 3) = msg.CC 
     Cells(row + 1, 4) = msg.To 
     Cells(row + 1, 5) = msg.SentOn 


     row = row + 1 
    Wend 

End Sub 

который использует функцию GetFileList, как определено ниже (благодаря spreadsheetpage.com)

Function GetFileList(FileSpec As String) As Variant 
' Taken from http://spreadsheetpage.com/index.php/tip/getting_a_list_of_file_names_using_vba/ 
' Returns an array of filenames that match FileSpec 
' If no matching files are found, it returns False 

    Dim FileArray() As Variant 
    Dim FileCount As Integer 
    Dim FileName As String 

    On Error GoTo NoFilesFound 

    FileCount = 0 
    FileName = Dir(FileSpec) 
    If FileName = "" Then GoTo NoFilesFound 

' Loop until no more matching files are found 
    Do While FileName <> "" 
     FileCount = FileCount + 1 
     ReDim Preserve FileArray(1 To FileCount) 
     FileArray(FileCount) = FileName 
     FileName = Dir() 
    Loop 
    GetFileList = FileArray 
    Exit Function 

' Error handler 
    NoFilesFound: 
     GetFileList = False 
End Function 

Должно быть довольно просто, дайте мне знать, если вам нужно больше объяснений.

Edit: Кроме того, вы должны добавить ссылку на библиотеку прогноз

HTH!

Z

Answer 3

«Код ниже будет иметь возможность работать практически со всеми сообщениями из Outlook, » за исключением, и я не знаю, почему, если вы работаете с сообщениями, генерируемых 'Exchange Server, такие как " Система доставки почты". Похоже, что это не сообщение 'на самом деле. Если вы попытаетесь прочитать его, то объект «olItem» будет 'always Empty. Однако, если вы получите это предупреждение «Система доставки почты» и переадресовываете 'себе, а затем попробуйте прочитать его, он работает нормально. Не спрашивайте меня «Почему, потому что я понятия не имею. Я просто думаю, что эта «система доставки почты» «в первый раз это предупреждение, а не сообщение, также значок меняет, это » - это не значок конверта, а доставка с успехом или нет. если у вас есть 'любая идея, как с этим обращаться, пожалуйста, adibise

Set olApp = New Outlook.Application 
Set olNamespace = olApp.GetNamespace("MAPI") 

Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox).Folders("mFolder") 


On Error Resume Next 

i = 5 
cont1 = 0 
Sheet2.Cells(4, 1) = "Sender" 
Sheet2.Cells(4, 2) = "Subject" 
Sheet2.Cells(4, 3) = "Received" 
Sheet2.Cells(4, 4) = "Recepient" 
Sheet2.Cells(4, 5) = "Unread?" 
Sheet2.Cells(4, 6) = "Link to Report" 

For Each olItem In olInbox.Items 

    myText = olItem.Subject 
    myTokens = Split(myText, ")", 5) 
    myText = Mid(myTokens(0), 38, Len(myTokens(0))) 
    myText = RTrim(myText) 
    myText = LTrim(myText) 
    myText = myText & ")" 
    myLink = "" 

    myArray = Split(olItem.Body, vbCrLf) 
    For a = LBound(myArray) To UBound(myArray) 
     If a = 4 Then 
      myLink = myArray(a) 
      myLink = Mid(myLink, 7, Len(myLink)) 
     End If 
    Next a 

    Sheet2.Cells(i, 1) = olItem.SenderName 
    Sheet2.Cells(i, 2) = myText 
    Sheet2.Cells(i, 3) = Format(olItem.ReceivedTime, "Short Date") 
    Sheet2.Cells(i, 4) = olItem.ReceivedByName 
    Sheet2.Cells(i, 5) = olItem.UnRead 
    Sheet2.Cells(i, 6) = myLink 
    olItem.UnRead = False 
    i = i + 1 

Next