Извлечение вложений из электронной почты .eml с использованием VBA - PullRequest
Новая
       116

Извлечение вложений из электронной почты .eml с использованием VBA

0 голосов
/ 25 марта 2020

В настоящее время я пишу код, который должен go во всех подпапках, и сохраняю вложения jpeg сохраненных писем. Код внизу прекрасно проснулся для файлов электронной почты .msg. Но клиент сохранил все письма, используя формат .eml. Теперь я получаю сообщение об ошибке в следующей строке: 

Set OLopenMsg = objOL.CreateItemFromTemplate(FileItem.Path)

Кто-нибудь имеет опыт работы с файлами .eml в VBA? Большое спасибо.

Полный код: 

Sub Main()

Call SwitchOnPerformanceImprovements

'variables/objects declaration 
    Dim objOL As Outlook.Application
    Set objOL = GetObject(, "Outlook.Application")
    Dim OLopenMsg As Outlook.MailItem
    Dim objns As Outlook.Namespace
    Dim counterMail, counterItems As Double

    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder, SubSubFolder As Object
    Dim FileItem As Scripting.File

    Dim strFolderIn, strFile, strFileType, strFolderOut, strPrefixNaming, oldAttachmentName, AttachmentFileType, newAttachmentName As String
    Dim i, counterAttachment As Integer

    Dim OLattachment As Outlook.Attachment
    Dim TargetFolder As Scripting.Folder
    Dim FileItemAttachment As Scripting.File

    Dim FSO2 As Scripting.FileSystemObject
    Set FSO2 = New Scripting.FileSystemObject
    strFolderOut = ThisWorkbook.Sheets("Input_Data").Range("B2").Value
    Set TargetFolder = FSO2.GetFolder(strFolderOut)

    Dim Myinspect As Outlook.Inspector


'set variables/objects

    Set objOL = CreateObject("Outlook.Application")

    Set FSO = New Scripting.FileSystemObject
    strFolderIn = ThisWorkbook.Sheets("Input_Data").Range("B1").Value
    Set SourceFolder = FSO.GetFolder(strFolderIn)

    counterMail = 10000
    counterItems = 2


'Main code

    For Each SubFolder In SourceFolder.SubFolders

        For Each FileItem In SubFolder.Files

            strFile = FileItem.Name
            strFileType = VBA.Right$(strFile, 4)

            If strFileType = ".eml" Then


                Set OLopenMsg = objOL.CreateItemFromTemplate(FileItem.Path)

                If OLopenMsg.Attachments.Count > 0 Then

                    strPrefixNaming = ThisWorkbook.Sheets("Input_Data").Range("B3").Value

                    For Each OLattachment In OLopenMsg.Attachments

                        oldAttachmentName = OLattachment.Filename   'Set Attachment Name
                        AttachmentFileType = VBA.Right$(oldAttachmentName, 4) 'Identify Attachment File Type

                        If AttachmentFileType = ".jpg" Then

                            'Saving Pictures with new name
                            OLattachment.SaveAsFile TargetFolder & "\" & strPrefixNaming & counterMail & "_" & counterAttachment & ".jpg"

                            ' Documenting in Excel
                            Sheets("Output").Cells(counterItems, 1) = SubFolder
                            Sheets("Output").Cells(counterItems, 3) = OLopenMsg.Subject
                            Sheets("Output").Cells(counterItems, 4) = OLopenMsg.SenderName
                            Sheets("Output").Cells(counterItems, 5) = OLattachment.Filename
                            newAttachmentName = strPrefixNaming & counterMail & "_" & counterAttachment & ".jpg"
                            Sheets("Output").Cells(counterItems, 6) = newAttachmentName

                    counterAttachment = counterAttachment + 1
                    counterItems = counterItems + 1

                    End If

                Next OLattachment


                OLopenMsg.Close olDiscard

                End If

            End If

            counterMail = counterMail + 1

        Next FileItem

    Next SubFolder

    Set objOL = Nothing

Call SwitchOffPerformanceImprovements

End Sub
...