保存到达电子邮件的附件

Question

我创建了一个 Outlook 规则来保存附件，然后将其移至“已删除邮件”文件夹。当我在收件箱中突出显示到达的电子邮件然后将电子邮件移动到已删除邮件文件夹时，该代码有效。

当新电子邮件到达时，它会将来自不同电子邮件的附件保存在收件箱中，而不是将电子邮件移动到已删除邮件文件夹中。

Outlook 规则是：

Apply this rule after the message arrives
from Sender
 and with Gift Card in the subject
 and on this computer only
run Project1.SaveAttachments

Public Sub SaveAttachments(MItem As Outlook.Mailitem)
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.Mailitem 'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim objNamespace As Outlook.NameSpace
    Dim objDestFolder As Outlook.MAPIFolder
    
On Error Resume Next

Set objOL = CreateObject("Outlook.Application")

Set objSelection = objOL.ActiveExplorer.Selection

strFolderpath = "Y:\"

For Each objMsg In objSelection

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    strDeletedFiles = ""

    If lngCount > 0 Then

        For i = lngCount To 1 Step -1

            strFile = objAttachments.Item(i).FileName
            strFile = strFolderpath & strFile
            objAttachments.Item(i).SaveAsFile strFile
        Next i
        Set objNamespace = objOL.GetNamespace("MAPI")
        Set objDestFolder = objNamespace.GetDefaultFolder(olFolderDeletedItems)
                    
        objMsg.Move objDestFolder

    End If
    
Next
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set objNamespace = Nothing
Set objDestFolder = Nothing

End Sub

Answer 1

根据我的测试，您可以使用以下代码保存电子邮件附件并删除它：

Sub SaveAutoAttach()

Dim object_attachment As Outlook.attachment

Dim saveFolder As String
Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim unRead, m As Object, att As Object
Dim some As String, other As String

Const olFolderInbox = 6

'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

'~~> Check if there are any actual unread emails
Set unRead = oOlInb.Items.Restrict("[UnRead] = True")

If unRead.Count = 0 Then
    MsgBox "NO Unread Email In Inbox"
Else

    some = ""
    other = ""
    saveFolder = "D:\"
    For Each m In unRead
        If m.Attachments.Count > 0 Then
            For Each object_attachment In m.Attachments
            ' Criteria to save .doc files only
                If InStr(object_attachment.DisplayName, ".doc") Then
                    object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
                End If
             Next
        End If
        m.Delete
    Next m
End Sub

更多信息，请参考此链接：

Auto Download Outlook Email Attachment – Code in VBA by Topbullets.com