VBA/Outlook extracting attachments from .eml files - vba

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 !

Answer 1

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