Question

我有大量的Outlook .msg和Outlook .eml文件保存到共享网络文件夹（即Outlook外部）。我试图在Excel中编写一些VBA，从每个文件中提取主题，发件人，CC，接收者，SentTime，SentDate，邮件正文文本，并将这些信息有序地导入Excel单元格

主题发件人CC Receiver SentTime SentDate

Re：.. Mike Jane Tom 12:00:00 2013年1月23日

我用word文档做了类似的事情，但我正在努力做到＆＃39; .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

所以我已经能够使用保存在outlook之外的.msg文件。但是，由于我无法访问Outlook Express，因此目前无法保存任何.eml文件。这是我想出的Sub，它会将Subject，Sender，CC，To和SendOn插入到第2行第1列开始的excel工作表中（假设第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

应该相当简单，如果您需要更多解释，请告诉我。

编辑：您还必须添加对outlook库的引用

HTH！

ž

Answer 2

假设你知道，或者可以计算完整的文件名＆amp; .msg的路径：

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

Set MyMail = MyOutlook.CreateItemFromTemplate(fName)`

Answer 3

'下面的代码几乎可以处理来自Outlook的所有邮件， '除了，我不知道为什么你正在处理由...生成的消息 'Exchange Server，例如“邮件传递系统”。它确实看起来不是一个 '此时真的有消息。如果你试着读它，对象“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

使用Excel中的VBA提取Outlook消息正文文本

3 个答案: