Question

删除电子邮件附件时，代码也会删除已插入电子邮件正文中的图像。

Option Explicit

Sub SaveMailAttachments()
'On Error Resume Next
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Dim Inbox As MAPIFolder
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Dim SaveFolder As String, StrFile As String
Dim subFolder As MAPIFolder
Dim Item As Object
Dim Attach As Attachment
Dim FileName As String
Dim i As Integer, x As Integer
Dim searchDate As String, searchDate2 As String
Dim RcvDate As Date, SrchDate As Date, RangeDate As Date

SaveFolder = BrowseForFolder("Select the folder you will like to save the attachments to.")
If SaveFolder = vbNullString Then Exit Sub

searchDate = InputBox("Please enter date within the past 2 weeks to search from (mm/dd/yyyy)")
If searchDate <> vbNullString Then

    SrchDate = Format(CDate(searchDate), "Short Date")
    RangeDate = Format((Date - 25), "Short Date")

    If SrchDate <= RangeDate Then
        MsgBox ("The date was not within 25 days, please try again")
        Exit Sub
    Else
    End If   

    ElseIf searchDate = vbNullString Then
    Exit Sub
End If

For i = Inbox.Items.Count To 1 Step -1

    Set Item = Inbox.Items(i)
    'i = 0

    RcvDate = Format(Item.SentOn, "Short Date")

    If RcvDate <= SrchDate Then

        If SrchDate = RcvDate Then

            For x = Item.Attachments.Count To 1 Step -1

                Set Attach = Item.Attachments(x)

                FileName = SaveFolder & "\" & Attach.FileName
                Attach.SaveAsFile FileName
                StrFile = Attach.FileName & ";" & StrFile
                Attach.Delete

                If Item.BodyFormat <> olFormatHTML Then
                    Item.Body = "The file(s) removed were: " & StrFile & vbCrLf & Item.Body
                Else
                    Item.HTMLBody = "" & "The file(s) removed were: " & " " & StrFile & "<br><br>" & Item.HTMLBody
                End If

                Item.Save
                StrFile = ""

            Next x

        Else
             Exit Sub
        End If
    End If
Next i

End Sub

'Function purpose:  To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE:  If invalid, it will open at the Desktop level
Function BrowseForFolder(Optional Prompt As String, Optional OpenAt As Variant) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error handler if found
'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else: GoTo Invalid
End Select

Exit Function
Invalid:
 'If it was determined that the selection was invalid, set to False
  BrowseForFolder = vbNullString
End Function

Function BrowseForFile(Optional Prompt As String, Optional OpenAt As Variant) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 16 + 16384, OpenAt)

On Error Resume Next
BrowseForFile = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error handler if found
'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else: GoTo Invalid
End Select

Exit Function
Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFile = vbNullString
End Function

Answer 1

隐藏附件具有以下MAPI属性集：

PR_ATTACH_CONTENT_ID（“http://schemas.microsoft.com/mapi/proptag/0x3712001F”）
PR_ATTACHMENT_HIDDEN（“http://schemas.microsoft.com/mapi/proptag/0x7FFE000B”）

此外，正文的HTML标记应包含内容ID属性集。

您可以使用以下代码作为基础（原始草图）：

Sub DeleteVisibleAttachments()
Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"

Dim m As MailItem
Dim a As Attachment
Dim pa As PropertyAccessor
Dim c As Integer
Dim cid as String

Dim body As String

Set m = Application.ActiveInspector.CurrentItem
body = m.HTMLBody

For Each a In m.Attachments
    Set pa = a.PropertyAccessor
    cid = pa.GetProperty(PR_ATTACH_CONTENT_ID)

    If Len(cid) > 0 Then
        If InStr(body, cid) Then            
            If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
                a.Delete
            End If
         End If
    Else
        a.Delete
    End If
Next a
End Sub

因此，您可以检测隐藏的附件并跳过它。

删除附件时保留电子邮件图像

1 个答案: