Сохранять изображения электронной почты при удалении вложений

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-разметка тело должно содержать свойство идентификатора содержимого.

Вы можете использовать следующий код в качестве основы (сырой эскиз):

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 

Таким образом, вы можете обнаружить скрытые прикрепленный и пропустить его.