使用Excel中的VBA提取outlook郵件正文文本

我有大量的Outlook .msg和Outlook .eml文件保存到共享網絡文件夾（即Outlook之外）。我嘗試寫一些VBA在Excel中提取主題，發件人，CC，接收器，SentTime，SentDate，郵件正文每個文件的文本，然後導入這些信息以Excel單元格有序使用Excel中的VBA提取outlook郵件正文文本

主題發件人CC接收SentTime SentDate

回覆：Mike Jane Tom 12:00:00 2013年1月23日

我已經用word文檔做了類似的事情，但我很努力地在.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

問候

來源

2013-04-18 Andy

假設你知道的，或者可以計算的。味精的完整文件名&路徑：

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

Set MyMail = MyOutlook.CreateItemFromTemplate(fName)`

來源

2013-04-18 04:27:26

所以我已經能夠讓它能夠在保存在Outlook之外的.msg文件的情況下工作。但是，由於我無法訪問Outlook Express，因此目前無法保存任何.eml文件。這裏有一個小組，我想出了將插入主題，發件人，CC，爲了和山頓到Excel工作表開始第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

這使用下面定義（感謝spreadsheetpage.com）的GetFileList功能

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

應該是相當簡單的，讓我知道如果你需要任何更多的解釋。

編輯：你還必須添加一個對outlook庫的引用

HTH！

來源

2013-04-23 15:54:45

「下面的代碼將能夠從Outlook幾乎所有郵件的工作，」除了和我不知道爲什麼，如果你是如的Exchange服務器上生成的消息的工作「郵件傳送系統」。它看起來好像不是 '真正的信息在這一點上。如果嘗試讀取它，對象「olItem」爲 '始終爲空。但是，如果您收到此警報「郵件傳遞系統」並將 '轉發給您自己，然後嘗試閱讀它，它確實工作正常。不要問我 '爲什麼因爲我不知道。我只是認爲這個「郵件傳遞系統」 '第一次是一個警報，而不是一個消息，圖標也改變了，它不是一個信封圖標，而是一個成功或不成功的交付圖標。如果您有任何想法如何處理它，請致電

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

來源

2017-03-16 19:34:36

使用Excel中的VBA提取outlook郵件正文文本

回答

相關問題