[zhuk09]

Пойду еще дальше, выложу сам скрипт

Код:

Function ChangeAgingProperties(oFolder As Outlook.Folder, _
    AgeFolder As Boolean, DeleteItems As Boolean, _
    FileName As String, Granularity As Integer, _
    Period As Integer, Default As Integer) As Boolean
    
    '6 MAPI properties for aging items in a folder
    Const PR_AGING_AGE_FOLDER = _
        "http://schemas.microsoft.com/mapi/proptag/0x6857000B"
    Const PR_AGING_DELETE_ITEMS = _
        "http://schemas.microsoft.com/mapi/proptag/0x6855000B"
    Const PR_AGING_FILE_NAME_AFTER9 = _
        "http://schemas.microsoft.com/mapi/proptag/0x6859001E"
    Const PR_AGING_GRANULARITY = _
        "http://schemas.microsoft.com/mapi/proptag/0x36EE0003"
    Const PR_AGING_PERIOD = _
        "http://schemas.microsoft.com/mapi/proptag/0x36EC0003"
    Const PR_AGING_DEFAULT = _
        "http://schemas.microsoft.com/mapi/proptag/0x685E0003"
    
    Dim oStorage As StorageItem
    Dim oPA As PropertyAccessor
    
    ' Valid Period:
    ' 1-999
    '
    ' Valid Granularity:
    ' 0=Months, 1=Weeks, 2=Days
    '
    ' Valid Default:
    ' 0=All settings do not use a default setting
    ' 1=Only the file location is defaulted
    ' "Archive this folder using these settings" and
    ' "Move old items to default archive folder" are checked
    ' 3=All settings are defaulted
    ' "Archive items in this folder using default settings" is checked
    
    If (oFolder Is Nothing) Or _
        (Granularity < 0 Or Granularity > 2) Or _
        (Period < 1 Or Period > 999) Or _
        (Default < 0 Or Default = 2 Or Default > 3) _
    Then
        ChangeAgingProperties = False
    End If
        
    On Error GoTo Aging_ErrTrap
    
    'Create or get solution storage in given folder by message class
    Set oStorage = oFolder.GetStorage( _
        "IPC.MS.Outlook.AgingProperties", olIdentifyByMessageClass)
    Set oPA = oStorage.PropertyAccessor
    
    If Not (AgeFolder) Then
        oPA.SetProperty PR_AGING_AGE_FOLDER, False
    Else
        'Set the 6 aging properties in the solution storage
        oPA.SetProperty PR_AGING_AGE_FOLDER, True
        oPA.SetProperty PR_AGING_GRANULARITY, Granularity
        oPA.SetProperty PR_AGING_DELETE_ITEMS, DeleteItems
        oPA.SetProperty PR_AGING_PERIOD, Period
        If FileName <> "" Then
            oPA.SetProperty PR_AGING_FILE_NAME_AFTER9, FileName
        End If
        oPA.SetProperty (PR_AGING_DEFAULT), Default
    End If
    'Save changes as hidden messages to the associated portion of the folder
    oStorage.Save
    ChangeAgingProperties = True
    Exit Function
    
Aging_ErrTrap:
    Debug.Print Err.Number, Err.Description
    ChangeAgingProperties = False
End Function

Sub TestAgingProps()
    Dim oFolder As Outlook.Folder
    Set oFolder = Application.ActiveExplorer.CurrentFolder
    If ChangeAgingProperties(oFolder, True, False, "", 0, 6, 1) Then
        Debug.Print "ChangeAgingProperties OK"
    Else
        Debug.Print "ChangeAgingProperties Failed"
    End If
End Sub

Может так кто поможет?!