0

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

主题 发送者 CC 接收者 SentTime SentDate

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

我对 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

问候

4

3 回答 3

3

所以我已经能够让它与保存在 Outlook 之外的 .msg 文件一起使用。但是，由于我无法访问 Outlook Express，我目前无法保存任何 .eml 文件。这是我想出的一个 Sub，它将 Subject、Sender、CC、To 和 SendOn 插入到 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

它使用如下定义的 GetFileList 函数（感谢电子表格页面.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 库的引用

！

Z

于 2013-04-23T15:54:45.997 回答
0

假设您知道，或者可以计算 .msg 的完整文件名和路径：

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

Set MyMail = MyOutlook.CreateItemFromTemplate(fName)`
于 2013-04-18T04:27:26.703 回答
0

' 下面的代码将能够处理来自 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
于 2017-03-16T19:34:36.933 回答