VBA/Outlook從.eml文件中提取附件

Question

我試圖將附件中帶有.eml消息的文件夾全部提取出來，然後在其他文件夾中提取/重命名/保存附件。我的代碼：

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 

但我發現了通俗易懂這個錯誤在循環中的第一個文件，即行 集EML = OlApp.CreateItemFromTemplate（路徑& MsgFilePath.Name）：

-2147286960 (80030050) %1 already exists. 

關於正在進行的任何想法，非常感謝！

Answer 1

試試這個（久經考驗的）

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