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