Archiving with VBA


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.

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 Function


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
 
Ad

Advertisements

M

Michael Bauer [MVP - Outlook]

This demonstrates how to loop recursively through folders and its
subfolders:
http://www.vboffice.net/sample.html?mnu=2&pub=6&lang=en&smp=12&cmd=showitem

--
Best regards
Michael Bauer - MVP Outlook

: VBOffice Reporter for Data Analysis & Reporting
: Outlook Categories? Category Manager Is Your Tool
: <http://www.vboffice.net/product.html?pub=6&lang=en>


Am Mon, 8 Sep 2008 14:37:02 +0200 schrieb (e-mail address removed):
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.

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æ´ <= " & 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


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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top