没有附件时在特定邮件上显示回形针图标

Question

为了节省空间，我设计了不同的 VBA 模块，用于自动从已发送邮件中删除附件或手动（在宏运行时）从收到的邮件中删除附件。附件保存到我的本地硬盘驱动器，Outlook.Mailitem.HTMLBody 会更新为已保存附件的链接。

当附件从特定邮件中删除时，回形针图标自然会消失。我希望回形针图标对那些特定的消息保持可见，尽管它们不再有附件。

我可以创建一个小附件并将其添加到邮件中以使图标出现，但我不希望这样做。是否可以手动设置使回形针图标可见的属性？

我在想我可以使用PropertyAccessor.SetProperty 来设置SmartNoAttach 属性，以使图标出现，但我不确定如何，甚至是否可能。

这是我在ThisOutlookSession 中的代码，它会自动从已发送邮件中删除附件。我不是一个强大的编码员，所以欢迎对此代码提供任何反馈。

Public WithEvents objSentMails As Outlook.Items

Private Sub Application_Startup()

    Set objSentMails = Outlook.Application.Session.GetDefaultFolder(olFolderSentMail).Items
End Sub

Private Sub objSentMails_ItemAdd(ByVal Item As Object)

    Dim objSentMail As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim i As Long
    Dim lngCount As Long
    Dim strAttachmentInfo As String
    Dim strFile As String
    Dim strFilename As String
    Dim strDeletedFiles As String


On Error Resume Next

    'Only work on emails
    If Item.Class = olMail Then

        Set objSentMail = Item
        strFolderpath = "H:\Desktop\Attachments\Sent\" & Format(objSentMail.SentOn, "yyyy.mm.dd") & "\"


        'creates subdirectory based on sent date
        If Dir(strFolderpath, vbDirectory) = "" Then
            MkDir strFolderpath
        End If

        'converts emails to HTML format
        If objSentMail.BodyFormat <> olFormatHTML Then
            objSentMail.BodyFormat = olFormatHTML
            objSentMail.Save
        End If

        Set objAttachments = objSentMail.Attachments
        lngCount = objAttachments.Count

        strDeletedFiles = ""

        'cycles through all attachments, saves them, and removes them from the message

        If lngCount > 0 Then
            For i = lngCount To 1 Step -1
                strFile = objAttachments.Item(i).FileName
                strFilename = strFile
                strFile = strFolderpath & strFile

                'ignores small files (e.g. embedded social media logos)
                If objAttachments.Item(i).Size > 6000 Then
                    objAttachments.Item(i).SaveAsFile strFile
                    strDeletedFiles = strDeletedFiles & "<br><a style='color: #ffffff; !important;' href='file://" & strFile & "'>" & strFilename & "</a>"
                    objAttachments.Item(i).Delete
                End If
            Next i

            'Insert the information of removed attachments to the body
            If strDeletedFiles <> "" Then
                '90s style drop-shadow table
                objSentMail.HTMLBody = "<p><table style='border-spacing: 0;border-collapse: collapse;'><tr style='height: 5px'><td style='background:#54A5CB; width: 8px'></td><td style='background:#54A5CB; border-color:#54A5CB'></td><td style='background: #54A5CB;'></td><td style='width:8px'></td></tr><tr><td style='background: #54A5CB;'></td><td style='background: #54A5CB; color: #ffffff; padding: 0px; font-family:calibri;'><strong style='font-size: 18px'>Attachments:</strong> " & strDeletedFiles & "</td><td style='background: #54A5CB;'></td><td style='background: #264957; width: 8px'></td></tr><tr style='height: 5px'><td style='background: #54A5CB; width: 8px'></td><td style='background: #54A5CB;'></td><td style='background: #54A5CB;'></td><td style='background: #264957; width:8px'></td></tr><tr style='height: 5px'><td></td><td style='background: #264957'></td><td style='background: #264957'></td><td style='background: #264957'></td></tr></table></p><br>" & objSentMail.HTMLBody
                objSentMail.Save
            End If
        End If
    End If

Set objAttachments = Nothing
Set objSentMail = Nothing

End Sub

Answer 1

您是在正确的道路上，您可以使用PropertyAccessor.SetProperty 方法将SchemaName 指定的属性设置为Value 指定的值。

Sub DemoPropertyAccessorSetProperty() 
 Dim myProp As String 
 Dim myValue As Variant 
 Dim oMail As Outlook.MailItem 
 Dim oPA As Outlook.PropertyAccessor 
 'Get first item in the inbox 
 Set oMail = _ 
 Application.Session.GetDefaultFolder(olFolderInbox).Items(1) 
 'Name for custom property using the MAPI string namespace 
 myProp = "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8514000B" 
 myValue = True 
 'Set value with SetProperty call 
 'If the property does not exist, then SetProperty 
 'adds the property to the object when saved. 
 'The type of the property is the type of the element 
 'passed in myValue. 
 On Error GoTo ErrTrap 
 Set oPA = oMail.PropertyAccessor 
 oPA.SetProperty myProp, myValue 

 'Save the item 
 oMail.Save 
 Exit Sub 
ErrTrap: 
 Debug.Print Err.Number, Err.Description 
End Sub