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