用于将另一封电子邮件中的 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

任何帮助将非常感激。

Answer 1

下面的代码使用这种方法将电子邮件作为附件处理

测试附件是否是电子邮件消息(如果文件名以 msg 结尾)

如果附件是邮件，则保存为 "C:\temp\KillMe.msg" .

CreateItemFromTemplate用于访问保存的文件作为新消息 (msg2)

然后代码处理这个临时消息以将附件剥离到 fsSaveFolder

如果附件不是消息，则根据您当前的代码提取它

请注意，由于我没有您的 olFolder 结构，Windoes 版本， 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