Excel VBA：遍历.msg文件目录

Question

我有一本excel工作簿，可用来遍历文件夹中的一堆.msg文件，以提取“发送”，“发件人”和“主题”字段。 我可以提取信息，但是只能通过明确引用文件名（在本例中为test和test2）。 如何遍历目录中的所有.msg文件并提取相关信息？ 这是我到目前为止的内容：

Option Explicit

Sub getMsgData()


    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

    Dim mailDoc As Outlook.MailItem
    Dim i As Long
    i = 1

    Dim nam As Variant
    For Each nam In Array("test.msg", "test2.msg")
        Set mailDoc = olApp.Session.OpenSharedItem(ActiveWorkbook.Path & "\" & nam)
        Sheets("sheet1").Range("a1").Offset(i) = mailDoc.SentOn
        Sheets("sheet1").Range("a1").Offset(i, 1) = mailDoc.Sender
        Sheets("sheet1").Range("a1").Offset(i, 2) = mailDoc.Subject
        mailDoc.Close False
        i = i + 1
    Next nam

    olApp.Quit

    Set mailDoc = Nothing
    Set olApp = Nothing

End Sub

Answer 1

这将循环遍历目录中的每个文件。该文件是.msg文件。尚未使用OpenSharedItem，因此您可能需要直接＆“ \\”和myfile来代替myfile。 我不建议使用ActiveWorkbook.Path，但也许您没有其他方法，例如要求用户在FolderPicker中选择文件夹？

direct = ActiveWorkbook.Path
myfile = Dir(direct, "*.msg")  'sets myfile equal to the first file name
Do While myfile <> ""        'loops until there are no more files in the directory
        Set mailDoc = olApp.Session.OpenSharedItem(myfile)
        Sheets("sheet1").Range("a1").Offset(i) = mailDoc.SentOn
        Sheets("sheet1").Range("a1").Offset(i, 1) = mailDoc.Sender
        Sheets("sheet1").Range("a1").Offset(i, 2) = mailDoc.Subject
        mailDoc.Close False
        i = i + 1

     myfile = Dir            

Loop

Answer 2

您可以使用Dir功能执行此操作。 在此处找到如何使用它的示例。 对于您的情况，这是正确的代码：

Option Explicit

Sub getMsgData()


    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

    Dim mailDoc As Outlook.MailItem
    Dim i As Long
    i = 1

    Dim nam As String
    nam = Dir(ActiveWorkbook.Path & "\*.msg")
    Do While nam <> ""
        Set mailDoc = olApp.Session.OpenSharedItem(ActiveWorkbook.Path & "\" & nam)
        Sheets("sheet1").Range("a1").Offset(i) = mailDoc.SentOn
        Sheets("sheet1").Range("a1").Offset(i, 1) = mailDoc.Sender
        Sheets("sheet1").Range("a1").Offset(i, 2) = mailDoc.Subject
        mailDoc.Close False
        i = i + 1
        nam = Dir
    Loop

    olApp.Quit

    Set mailDoc = Nothing
    Set olApp = Nothing

End Sub