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

Question

为了节省空间，我设计了不同的VBA模块来自动从发送的邮件中删除附件，或者手动（在宏运行时）从收到的邮件中删除附件。 附件会被保存在我的本地硬盘上，而我的 Outlook.Mailitem.HTMLBody 更新了保存的附件的链接，当然，当附件从特定邮件中删除时，回形针图标会消失。

很自然地，当附件从特定邮件中移除时，回形针图标就会消失。 我想让回形针图标在这些邮件中保持可见，尽管它们不再有附件。

I 可以 创建一个小附件，并将其添加到消息中，以使图标显示，但我宁愿不这样做。 是否可以手动设置导致回形针图标可见的属性？

我想我可以使用 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