Option Explicit

''=======================================================================
''  Code for attaching my archive pst, moving older emails to
''  a specific folder within this pst and then detaching it.
''
''  In this example all items in the Deleted Items folder older than
''  60 days are moved to my own archive file into the 'Deletions' folder
''=======================================================================
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const m_strDeletedPST As String = "C:\Outlook_Data\archivage.pst"
Private Const m_strDelDispName As String = "Archives"
Private Const m_iDays As Integer = 60

Sub MoveOldMail()
''=======================================================================
''  This routine is visible as a macro and is the heart of the move process
''  Calls: AttachPST, DetachPST, Quote
''=======================================================================

On Error GoTo Proc_Err

    Dim blnSuccess As Boolean
    Dim objNS As Outlook.NameSpace
    Dim objAllItems As Outlook.Items
    Dim objItemsToMove As Outlook.Items
    Dim objItem As Object
    Dim objTargetFolder As Outlook.MAPIFolder
    Dim objPST As Outlook.MAPIFolder
    Dim strSearch As String
    Dim iCount As Integer
    Dim i As Integer

    ''Attach pst file
    blnSuccess = AttachPST(m_strDeletedPST, m_strDelDispName, objPST)

    If Not blnSuccess Then
        MsgBox "Could not attached '" & m_strDeletedPST & "', aborting
move."
        GoTo Proc_Exit
    End If

    '' Wait a couple of seconds for everything to catch up
    Sleep 3000

    ''We have the archive pst attached
    Set objNS = Application.GetNamespace("MAPI")
    Set objAllItems = objNS.GetDefaultFolder(olFolderDeletedItems).Items

    ''create filter based on date
    strSearch = "[Reçu] = " & Quote(FormatDateTime(Now - m_iDays,
vbShortDate) & " " & _
                 FormatDateTime(Now - m_iDays, vbShortTime))

    ''========== Move Deleted Items =============
    ''Get the 'Deletions' folder in the newly attached pst file
    Set objTargetFolder = objPST.Folders.Item("éléments supprimés")

    ''Now restrict the email according to date
    Set objItemsToMove = objAllItems.Restrict(strSearch)

    ''Get count of all items to be moved
    iCount = objItemsToMove.Count

    Debug.Print "Deleted Items: " & iCount

    '' Loop from back to front of the restricted collection, moving each
file
    For i = iCount To 1 Step -1
        objItemsToMove.Item(i).Move objTargetFolder
    Next


    '' Now detach the added pst file
    DetachPST m_strDelDispName

    '' Wait a couple of seconds for everything to catch up
    Sleep 3000


Proc_Exit:
    ''Clean up
    If Not objAllItems Is Nothing Then Set objAllItems = Nothing
    If Not objItem Is Nothing Then Set objItem = Nothing
    If Not objItemsToMove Is Nothing Then Set objItemsToMove = Nothing
    If Not objTargetFolder Is Nothing Then Set objTargetFolder = Nothing
    If Not objNS Is Nothing Then Set objNS = Nothing

    Exit Sub
Proc_Err:
    MsgBox Err.Description, , "MoveOldMail"
    GoTo Proc_Exit

End Sub

Private Function AttachPST(astrPSTName As String, astrDisplayName As String,
aobj As Outlook.MAPIFolder) As Boolean
''=======================================================================
''  This routine used the received information to attach an existing pst
''  file, returning a handle to the attached file
''=======================================================================
On Error GoTo Proc_Err
    Dim objNS As Outlook.NameSpace


    'Check if pst file exists, if exist then Add pst file...
    If Len(Dir$(astrPSTName)) = 0 Then
        MsgBox "Cannot connect to 'Deleted' pst file"
        Exit Function
    End If

    Set objNS = Application.GetNamespace("MAPI")
    objNS.AddStore astrPSTName
    Set aobj = objNS.Folders.GetLast
    'Change the Display Name from the new pst file ...
    aobj.Name = astrDisplayName

    '' Return success code
    AttachPST = True

Proc_Exit:
    ''If Not objFolder Is Nothing Then Set objFolder = Nothing
    If Not objNS Is Nothing Then Set objNS = Nothing
    Exit Function
Proc_Err:
    MsgBox Err.Description, , "AttachPST"
    AttachPST = False
    GoTo Proc_Exit
End Function


Function DetachPST(astrDisplayName As String) As Boolean
''=======================================================================
''  This routine used the received display name to close an existing pst
''  file
''=======================================================================
On Error GoTo Proc_Err
   Dim objNS As Outlook.NameSpace
   Dim objFolder As Outlook.MAPIFolder

    Set objNS = Application.GetNamespace("MAPI")
    Set objFolder = objNS.Folders.Item(astrDisplayName)
    objNS.RemoveStore objFolder

    '' Return success code
    DetachPST = True

Proc_Exit:
    If Not objFolder Is Nothing Then Set objFolder = Nothing
    If Not objNS Is Nothing Then Set objNS = Nothing
    Exit Function

Proc_Err:
    MsgBox Err.Description, , "DetachPST"
    DetachPST = False
    GoTo Proc_Exit

End Function

Private Function Quote(MyText)
    ''Used for properly quoting the filter string
    Quote = Chr(34) & MyText & Chr(34)
End Function

process
 ''  Calls: AttachPST, DetachPST, Quote
 ''=======================================================================
 
 On Error GoTo Proc_Err
 
     Dim blnSuccess As Boolean
     Dim objNS As Outlook.NameSpace
     Dim objAllItems As Outlook.Items
     Dim objItemsToMove As Outlook.Items
     Dim objItem As Object
     Dim objTargetFolder As Outlook.MAPIFolder
     Dim objPST As Outlook.MAPIFolder
     Dim strSearch As String
     Dim iCount As Integer
     Dim i As Integer
 
     ''Attach pst file
     blnSuccess = AttachPST(m_strDeletedPST, m_strDelDispName, objPST)
 
     If Not blnSuccess Then
         MsgBox "Could not attached '" & m_strDeletedPST & "', aborting
 move."
         GoTo Proc_Exit
     End If
 
     '' Wait a couple of seconds for everything to catch up
     Sleep 3000
 
     ''We have the archive pst attached
     Set objNS = Application.GetNamespace("MAPI")
     Set objAllItems = objNS.GetDefaultFolder(olFolderDeletedItems).Items
 
     ''create filter based on date
     strSearch = "[Reæ´� = " & Quote(FormatDateTime(Now - m_iDays,
 vbShortDate) & " " & _
                  FormatDateTime(Now - m_iDays, vbShortTime))
 
     ''========== Move Deleted Items =============
     ''Get the 'Deletions' folder in the newly attached pst file
     Set objTargetFolder = objPST.Folders.Item("è*©ments supprimè±¢)
 
     ''Now restrict the email according to date
     Set objItemsToMove = objAllItems.Restrict(strSearch)
 
     ''Get count of all items to be moved
     iCount = objItemsToMove.Count
 
     Debug.Print "Deleted Items: " & iCount
 
     '' Loop from back to front of the restricted collection, moving each
 file
     For i = iCount To 1 Step -1
         objItemsToMove.Item(i).Move objTargetFolder
     Next
 
 
     '' Now detach the added pst file
     DetachPST m_strDelDispName
 
     '' Wait a couple of seconds for everything to catch up
     Sleep 3000
 
 
 Proc_Exit:
     ''Clean up
     If Not objAllItems Is Nothing Then Set objAllItems = Nothing
     If Not objItem Is Nothing Then Set objItem = Nothing
     If Not objItemsToMove Is Nothing Then Set objItemsToMove = Nothing
     If Not objTargetFolder Is Nothing Then Set objTargetFolder = Nothing
     If Not objNS Is Nothing Then Set objNS = Nothing
 
     Exit Sub
 Proc_Err:
     MsgBox Err.Description, , "MoveOldMail"
     GoTo Proc_Exit
 
 End Sub
 
 Private Function AttachPST(astrPSTName As String, astrDisplayName As
String,
 aobj As Outlook.MAPIFolder) As Boolean
 ''=======================================================================
 ''  This routine used the received information to attach an existing pst
 ''  file, returning a handle to the attached file
 ''=======================================================================
 On Error GoTo Proc_Err
     Dim objNS As Outlook.NameSpace
 
 
     'Check if pst file exists, if exist then Add pst file...
     If Len(Dir$(astrPSTName)) = 0 Then
         MsgBox "Cannot connect to 'Deleted' pst file"
         Exit Function
     End If
 
     Set objNS = Application.GetNamespace("MAPI")
     objNS.AddStore astrPSTName
     Set aobj = objNS.Folders.GetLast
     'Change the Display Name from the new pst file ...
     aobj.Name = astrDisplayName
 
     '' Return success code
     AttachPST = True
 
 Proc_Exit:
     ''If Not objFolder Is Nothing Then Set objFolder = Nothing
     If Not objNS Is Nothing Then Set objNS = Nothing
     Exit Function
 Proc_Err:
     MsgBox Err.Description, , "AttachPST"
     AttachPST = False
     GoTo Proc_Exit
 End Function
 
 
 Function DetachPST(astrDisplayName As String) As Boolean
 ''=======================================================================
 ''  This routine used the received display name to close an existing pst
 ''  file
 ''=======================================================================
 On Error GoTo Proc_Err
    Dim objNS As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
 
     Set objNS = Application.GetNamespace("MAPI")
     Set objFolder = objNS.Folders.Item(astrDisplayName)
     objNS.RemoveStore objFolder
 
     '' Return success code
     DetachPST = True
 
 Proc_Exit:
     If Not objFolder Is Nothing Then Set objFolder = Nothing
     If Not objNS Is Nothing Then Set objNS = Nothing
     Exit Function
 
 Proc_Err:
     MsgBox Err.Description, , "DetachPST"
     DetachPST = False
     GoTo Proc_Exit
 
 End Function
 
 Private Function Quote(MyText)
     ''Used for properly quoting the filter string
     Quote = Chr(34) & MyText & Chr(34)
 End Function