首页 文章

VBA 代码可将另一封电子邮件中的 Outlook 电子邮件中的附件(Excel 文件)保存为附件

提问于
浏览
3

我有将附件保存在特定 Outlook 文件夹中的邮件中的代码。

如果电子邮件带有附件,我的脚本将起作用,但是如果电子邮件作为附件带有附件发送,则我的脚本将不起作用。

在这种情况下,我的电子邮件包含其他电子邮件作为附件(来自 auto-forward 规则)。然后,嵌入式电子邮件附件将包含 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

任何帮助将非常感激。

1 回答

  • 2

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

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

    • 如果附件是邮件,则另存为"C:\temp\KillMe.msg"

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

    • 然后,代码将处理此临时消息,以将 Attachmnets 剥离到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
    

相关问题