从另一个作为附件的Outlook电子邮件中保存附件（Excel文件）的VBA代码

Question

我有一段代码，可以将邮件中的附件保存到指定的Outlook文件夹中。

如果邮件本身带有附件，我的脚本可以正常工作，但如果邮件是作为附件带有附件发送的，则无法正常工作。

在这种情况下，我的邮件包含其他邮件作为附件（来自自动转发规则）。嵌入的电子邮件附件然后包含Excel文件。

请参见我的当前vba如下：

Public Sub SaveOlAttachments()
  Dim isAttachment As Boolean
  Dim olFolder As Outlook.MAPIFolder
  Dim msg As Outlook.MailItem
  Dim att As Outlook.Attachment
  Dim fsSaveFolder, sSavePathFS, ssender As String

  On Error GoTo crash

  fsSaveFolder = "C:\Documents and Settings\user\Desktop\"
  isAttachment = False
  Set olFolder = Outlook.GetNamespace("MAPI").Folders("...email server...")
  Set olFolder = olFolder.Folders("Inbox")
  If olFolder Is Nothing Then Exit Sub

  For Each msg In olFolder.Items
    If UCase(msg.Subject) = "TEST EMAIL WITH ATTACHMENT" Then
                    If msg.Attachments.Count > 0 Then
          While msg.Attachments.Count > 0
                sSavePathFS = fsSaveFolder & msg.Attachments(1).Filename
            msg.Attachments(1).SaveAsFile sSavePathFS
            msg.Attachments(1).Delete
            isAttachment = True
          Wend
          msg.Delete
        End If
    End If    
  Next

crash:
  If isAttachment = True Then Call findFiles(fsSaveFolder)
End Sub

任何帮助都将不胜感激。

- JAM_864

Answer 1

以下代码使用此方法处理附件中的电子邮件：

1. 测试附件是否为电子邮件（如果文件名以msg结尾）
2. 如果附件是一条消息，则将其保存为"C：\ temp \ KillMe.msg"。
3. 使用CreateItemFromTemplate访问已保存的文件作为新消息（msg2）
4. 然后，该代码会处理此临时消息以剥离附件到fsSaveFolder
5. 如果附件不是消息，则按照您当前的代码进行提取

请注意，由于我没有您的olFolder结构，Windows版本和Outlook变量等信息，因此我不得不添加自己的文件路径和Outlook文件夹进行测试。 您需要更改这些。

   Sub SaveOlAttachments()

    Dim olFolder As Outlook.MAPIFolder
    Dim msg As Outlook.MailItem
    Dim msg2 As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim strTmpMsg As String
    Dim fsSaveFolder As String

    fsSaveFolder = "C:\test\"

    'path for creating attachment msg file for stripping
    strFilePath = "C:\temp\"
    strTmpMsg = "KillMe.msg"

   'My testing done in Outlok using a "temp" folder underneath Inbox
    Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set olFolder = olFolder.Folders("Temp")
    If olFolder Is Nothing Then Exit Sub

    For Each msg In olFolder.Items
        If msg.Attachments.Count > 0 Then
        While msg.Attachments.Count > 0
        bflag = False
            If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
                bflag = True
                msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
                Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
            End If
            If bflag Then
                sSavePathFS = fsSaveFolder & msg2.Attachments(1).FileName
                msg2.Attachments(1).SaveAsFile sSavePathFS
                msg2.Delete
            Else
                sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
                msg.Attachments(1).SaveAsFile sSavePathFS
            End If
            msg.Attachments(1).Delete
            Wend
             msg.Delete
        End If
    Next
    End Sub

- brettdj

---

完美运行！我唯一改变的是：Application.CreateItemFromTemplate(strFilePath & strTmpMsg)改为Outlook.CreateItemFromTemplate(strFilePath & strTmpMsg) - JAM_864