VBA/Outlook extracting attachments from .eml files

Question

I'm trying to take a folder full of .eml messages with attachments and then extract/rename/save the attachments in another folder. My code :

Sub SaveAttachments()
    Dim OlApp As Outlook.Application
    Set OlApp = GetObject(, "Outlook.Application")
    Dim MsgFilePath
    Dim Eml As Outlook.MailItem
    Dim att As Outlook.Attachments
    Dim Path As String
    Path = "C:\Users\richard\Desktop\Inbox\"

    If OlApp Is Nothing Then
        Err.Raise ERR_OUTLOOK_NOT_OPEN
    End If

    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    Dim temp As Object
    Set temp = fs.GetFolder(Path)

    For Each MsgFilePath In temp.Files
        Set Eml = OlApp.CreateItemFromTemplate(Path & MsgFilePath.Name)

    Set att = Eml.Attachments
        If att.Count > 0 Then
            For i = 1 To att.Count
                fn = "C:\Users\richard\Desktop\cmds\" & Eml.SenderEmailAddress
                att(i).SaveAsFile fn
            Next i
        End If


        Set Eml = Nothing
    Next

    Set OlApp = Nothing
End Sub

But I'm getting straightaway this error on the first file in the loop, ie the line Set Eml = OlApp.CreateItemFromTemplate(Path & MsgFilePath.Name) :

-2147286960 (80030050)    %1 already exists.

Any ideas on what is going on much appreciated !

Birds View: Since you have mot mentioned which line, is it this line att(i).SaveAsFile fn? — Siddharth Rout
Also if there are several emails from the same sender then your code will attempt to overwrite the file... "C:\Users\richard\Desktop\cmds\" & Eml.SenderEmailAddress — Siddharth Rout
thanks for the suggestions - i can confirm that the error occurs on the FIRST loop (so no other files have yet been opened/created), and that just in case all emails have different from addresses. Have updated the question to show the line causing the error — Petrov
the entire error message is Run-time error "-2147286960 (80030050)": Cannot open file: C:\Users\Mauro\AppData\Local\Microsoft\Windows\Temporary Internet Files\Content..... The file may not exist, you may not have permission to open it, or it may be open in another program. Right-click the folder that contains the file, and then click Properties to check your permissions for the folder. — Petrov

Siddharth Rout Siddharth Rout · Accepted Answer · 2013-10-08T18:33:36

Try this (TRIED AND TESTED)

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As _
String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWMINIMIZED As Long = 2

Sub SaveAttachments()
    Dim OlApp As Outlook.Application
    Set OlApp = GetObject(, "Outlook.Application")
    Dim MsgFilePath
    Dim Eml As Outlook.MailItem
    Dim att As Outlook.Attachments
    Dim sPath As String
    sPath = "C:\Users\richard\Desktop\Inbox\"

    If OlApp Is Nothing Then
        Err.Raise ERR_OUTLOOK_NOT_OPEN
    End If

    sFile = Dir(sPath & "*.eml")

    Do Until sFile = ""
        ShellExecute 0, "Open", sPath & sFile, "", sPath & sFile, SW_SHOWNORMAL

        Wait 2

        Set MyInspect = OlApp.ActiveInspector
        Set Eml = MyInspect.CurrentItem

        Set att = Eml.Attachments
        If att.Count > 0 Then
            For i = 1 To att.Count
                fn = "C:\Users\richard\Desktop\cmds\" & i & "-" & Eml.SenderEmailAddress
                att(i).SaveAsFile fn
            Next i
        End If

        sFile = Dir$()
    Loop

    Set OlApp = Nothing
End Sub

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

VBA/Outlook extracting attachments from .eml files

1 Answers