时间戳

首页 > 解决方案 > 没有附件时在特定邮件上显示回形针图标

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

问题描述

为了节省空间，我有不同的 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

标签： vbaoutlook

解决方案

您在正确的道路上，您可以使用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

推荐阅读