Как назначить тег хранения для элемента почты в Outlook VBA?

Question

Я пытаюсь написать макрос, который будет проходить через папку в Outlook, назначая тег хранения (docs) некоторым элементам, основанным на некоторых сложных критериях.

Я не знаю, как это сделать в VBA. До сих пор я узнал, что почтовые отправления имеют некоторые свойства, связанные с сохранением (PidTagPolicyTag (docs) и т. Д.), Но я до сих пор не знаю, как правильно их обрабатывать.

Каковы будут примеры использования этих данных?

Answer 1

Просмотрите существующее сообщение с этими свойствами, заданными с помощью OutlookSpy (щелкните IMessage) или MFCMAPI. Свойства можно задать с помощью MailItem.PropertyAccessor.SetProperty.

Answer 2

Ниже приведен пример использования тега хранения сообщений с помощью Outlook, VBA:

Option Explicit 

Private Sub Application_Startup() 
    Const retPolicy7Y As String = "C16486BDBB1B384C9BDE0C2479537191" 'Document Retention - 07 Years (7 years) 
    Const retPeriod As Long = 2555 '7*365 days 
    Dim mapi As NameSpace, sentItems As Items, cutOffDate As Date 
    Dim i As Long, pa As PropertyAccessor, p As Variant, isEqual As Boolean, msgDate As Variant 

    Set mapi = GetNamespace("MAPI") 
    Set sentItems = mapi.GetDefaultFolder(olFolderSentMail).Items 
    sentItems.Sort "SentOn", True 
    cutOffDate = Now - 14 

    For i = 1 To sentItems.Count 
     If sentItems(i).SentOn <= cutOffDate Then 
      Exit For 
     End If 

     Set pa = sentItems(i).PropertyAccessor 
     p = Empty 
     On Error Resume Next 
     p = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30190102") 'Get PR_POLICY_TAG 
     On Error GoTo 0 

     If IsEmpty(p) Then 
      isEqual = False 
     ElseIf pa.BinaryToString(p) <> retPolicy7Y Then 
      isEqual = False 
     Else 
      isEqual = True 
     End If 

     If Not isEqual Then 
      msgDate = Empty 
      On Error Resume Next 
      msgDate = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E060040") 'Get PR_MESSAGE_DELIVERY_TIME 
      On Error GoTo 0 
      If IsEmpty(msgDate) Then 
       msgDate = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30070040") 'Get PR_CREATION_TIME 
      End If 

      pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30190102", pa.StringToBinary(retPolicy7Y) 'Set PR_POLICY_TAG 
      pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301A0003", retPeriod 'Set PR_RETENTION_PERIOD 
      pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301C0040", msgDate + retPeriod 'Set PR_RETENTION_DATE 
      sentItems(i).Save 
     End If 
    Next i 
End Sub