Извлечение вложений из файлов *.msg, хранящихся во многих подпапках

Приведенный ниже код извлекает вложения из файлов *.msg, хранящихся в одной папке.

Я пытаюсь извлечь вложения из файлов *.msg, хранящихся во многих подпапках внутри папки.

Путь к основной папке:
U:\XXXXX\XXXXX\Main Folder

Пути для вложенных папок:
U:\XXXXX\XXXXX\Main Folder\Folder1
U:\XXXXX\XXXXX\Main Folder\Folder2
U:\XXXXX\XXXXX\Main Folder\Folder3< бр> и т.д.

Sub SaveOlAttachments()

Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String

    'path for msgs
strFilePath = "U:\XXXXX\XXXXX\Main Folder\"
    'path for saving attachments
strAttPath = "D\Attachments\"

strFile = Dir(strFilePath & "*.msg")
Do While Len(strFile) > 0
    Set msg = Application.CreateItemFromTemplate(strFilePath & strFile)
    If msg.Attachments.Count > 0 Then
         For Each att In msg.Attachments
             att.SaveAsFile strAttPath & att.FileName
         Next
    End If
    strFile = Dir
Loop

End Sub

outlook vba email-attachments subdirectory msg
person Obada Talal    schedule 11.01.2018    source источник
comment
stackoverflow.com/questions/20687810/   -  person Tim Williams    schedule 11.01.2018
comment
Большое спасибо, Тим, за оперативный ответ. Очень признателен. Поскольку мои знания VBA ограничены, не могли бы вы сделать мне одолжение и объединить два кода вместе. Еще раз спасибо, Тим :)   -  person Obada Talal    schedule 11.01.2018
comment
Возможный дубликат макроса VBA, который ищет файл в нескольких подпапках   -  person F0XS    schedule 11.01.2018
comment
Спасибо Фокс Си. Я был бы признателен, если бы коды можно было объединить вместе, чтобы извлечь все вложения из полученных файлов *.msg. Ценится.   -  person Obada Talal    schedule 11.01.2018

Ответы (1)


arrow_upward
0
arrow_downward

Используя мой ответ из макроса VBA, который ищет файл в нескольких подпапках

Sub SaveOlAttachments()

    Dim msg As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim strAttPath As String
    Dim colFiles As New Collection, f

    'path for msgs
    strFilePath = "U:\XXXXX\XXXXX\Main Folder\"

    GetFiles strFilePath , "*.msg", True, colFiles

    'path for saving attachments
    strAttPath = "D\Attachments\"

    For Each f in colFiles
        Set msg = Application.CreateItemFromTemplate(f)
        If msg.Attachments.Count > 0 Then
             For Each att In msg.Attachments
                 att.SaveAsFile strAttPath & att.FileName
             Next
        End If
    Next

End Sub

Sub для выполнения поиска:

Sub GetFiles(StartFolder As String, Pattern As String, _
             DoSubfolders As Boolean, ByRef colFiles As Collection)

    Dim f As String, sf As String, subF As New Collection, s

    If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"

    f = Dir(StartFolder & Pattern)
    Do While Len(f) > 0
        colFiles.Add StartFolder & f
        f = Dir()
    Loop

    sf = Dir(StartFolder, vbDirectory)
    Do While Len(sf) > 0
        If sf <> "." And sf <> ".." Then
            If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
                    subF.Add StartFolder & sf
            End If
        End If
        sf = Dir()
    Loop

    For Each s In subF
        GetFiles CStr(s), Pattern, True, colFiles
    Next s

End Sub
person Tim Williams    schedule 11.01.2018
comment
Большое спасибо, Тим, за твои усилия. Я пробовал код, но получаю сообщение об ошибке компиляции, подпрограмма или функция не определены. Есть мысли с вашей стороны? - person Obada Talal; 12.01.2018
comment
Вы скопировали подпункт GetFiles из связанного вопроса? Я добавил это выше. - person Tim Williams; 12.01.2018
comment
Это сработало потрясающе! Большое спасибо, Тим. Желаю вам всего наилучшего в вашей жизни и карьере. Желаю отличного дня! - person Obada Talal; 16.01.2018