Question

我创建了一个Outlook规则来保存附件，然后将其移动到Deleted Items文件夹中。当我在“收件箱”中突出显示收到的电子邮件，然后将其移到“已删除邮件”文件夹中时，该规则将起作用。但是，当新电子邮件到达时，它会将来自其他电子邮件的附件保存在收件箱中，而不会将电子邮件移到“已删除邮件”文件夹中。

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

Outlook VBA保存附件在收到的电子邮件中保存了错误的附件

1 个答案: