使用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邮件正文文本

回答

相关问题