G
Guest
Hello all
I found a code on http://www.outlookcode.com
The latter to the advantage of opening a pst archives, moving the former
mails
from a folder (in this example: deleted items) and then closed the
PST.
I know how he indicated the box receipt but not how to tell him to go
through all subfolders and me recreate the same tree in the pst archiving.
If someone can help me fill this code would be super.
Thanks in advance
seb
I found a code on http://www.outlookcode.com
The latter to the advantage of opening a pst archives, moving the former
mails
from a folder (in this example: deleted items) and then closed the
PST.
Code:
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 FunctionI know how he indicated the box receipt but not how to tell him to go
through all subfolders and me recreate the same tree in the pst archiving.
If someone can help me fill this code would be super.
Thanks in advance
seb