asked on

VBA Outlook archiv Folders and Emails

Hello Everybody

I need a vba script that is able to move emails to an "Archiv" Mailbox.
The Script should be able to ask and check the date of each email.
and should only move those mails who are older than this date.

Also importat: it should be able to create the same folder structure on the target Mailbox "Archiv".

thanks

dlmille

This app prompts you for a mail item received date such that all mail items on or before that date will be moved. You are then prompted for a source, then destination folder (which must initially exist). The source folder structure is replicated to the destination folder, if needed. Then, each mail item in the source folder is evaluated against the prompted received date and then moved to the appropriate destination (re: Archive) folder.

Here's the code:

Option Explicit
Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As MailItem
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            If mItem.ReceivedTime <= recDate Then
                mItem.Move subDestFolder
            End If
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete!"

exitSub:

End Sub
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, fld As MAPIFolder)

Dim subFolder As MAPIFolder


    Folders.Add fld.FolderPath
    EntryID.Add fld.EntryID
    StoreID.Add fld.StoreID

    For Each subFolder In fld.Folders
        GetFolder Folders, EntryID, StoreID, subFolder
    Next subFolder

exitSub:

    Set subFolder = Nothing

End Sub
Function GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            newFolder = chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window

You must paste this in a public module in your Outlook VBA editor (hit Alt-F11 and insert a public module). You can then run the macro called: ArchiveEmails_ProcessAllSubFolders()

Please advise any questions.

Cheers,

Dave

HelpdeskJBC

ASKER

Hello dave,

thanks for the great work!

Unfortunately there is a Problem with "delivered" notifications and maybe with calender entrys etc are these different objects?

This line (60) makes an error:
Set mItem = subFolder.Items(j)
Runtime Error 13
Type mismatch

print subFolder.Items(j)
Delivered: test

dlmille

>> Unfortunately there is a Problem with "delivered" notifications and maybe with calender entrys etc are these different objects?

They are but they still exist as SubFolder.Items (obviously!) We just need to change the datatype for mItem to Object as opposed to MailItem and then anything in the folder should move over. I tested with a calendar and contact item and worked for me.

Here's the revised code:

Option Explicit

Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As Object 'MailItem
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            If mItem.ReceivedTime <= recDate Then
                mItem.Move subDestFolder
            End If
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete!"

exitSub:

End Sub
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, fld As MAPIFolder)

Dim subFolder As MAPIFolder


    Folders.Add fld.folderPath
    EntryID.Add fld.EntryID
    StoreID.Add fld.StoreID

    For Each subFolder In fld.Folders
        GetFolder Folders, EntryID, StoreID, subFolder
    Next subFolder

exitSub:

    Set subFolder = Nothing

End Sub
Function GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            newFolder = chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window

Dave

HelpdeskJBC

ASKER

Hy dave!

I still get this error on the Delivered Items:

Run time Error 438
Object doesn't support this property or method

seems like this ist not supportet: print mItem.ReceivedTime
but can you handle it with the mItem.CreationTime ? for example only on error?

thanks for the help

dlmille

Can do an error trap. But first, What line are you getting that error on?

dlmille

I see - line 62 - did you take a coffee break? We can do this much more quickly if you respond - I'm up at 2:10am, so if you want to knock this out, let me know.

:)

Dave

dlmille

This code checks both ReceivedTime as well as CreationTime. If either one does not create an error, it moves it, otherwise it advises you then continues on.

Please advise. Its possible you have a corrupt record in the excel folder/database. See if you can export that record, then delete it in your outlook folder, then reimport it. Not sure that would fix things, but would be interesting to find out. I don't have these problems of course, as I'm working with test data at this point, so its hard to reproduce a malformed record if that is what it is. If its a Delivered Item as you say, then corruption may be the case. Let's see what percentage of records fail. You should be prompted with the error rate, and your immediate window will summarize all the subjects that failed, if they are not corrupt and actually print!

Option Explicit
Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As Object 'MailItem 'Early Binding
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

Dim chkTime As Date
Dim iError As Long
Dim iRecords As Long

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            On Error Resume Next
            chkTime = mItem.ReceivedTime
            If Err.Number <> 0 Then
                Err.Clear
                chkTime = mItem.CreationTime
            End If
            If Err.Number <> 0 Then
                'MsgBox "Unable to move Mail Item Subject: " & mItem.Subject
                Debug.Print "Unable to move Mail Item Subject: " & mItem.Subject
                iError = iError + 1
            Else
                On Error GoTo 0
                If chkTime <= recDate Then
                    mItem.Move subDestFolder
                End If
            End If
            On Error GoTo 0
            iRecords = iRecords + 1
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete! with " & iError & " Errors out of " & iRecords & " Processed - " & Format(iError / iRecords, "0.00%") & " Error rate"

exitSub:

End Sub
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, fld As MAPIFolder)

Dim subFolder As MAPIFolder


    Folders.Add fld.FolderPath
    EntryID.Add fld.EntryID
    StoreID.Add fld.StoreID

    For Each subFolder In fld.Folders
        GetFolder Folders, EntryID, StoreID, subFolder
    Next subFolder

exitSub:

    Set subFolder = Nothing

End Sub
Function GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            newFolder = chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window

HelpdeskJBC

ASKER

The Program is now running without any errors, looks good, but I have problems with the destination folder. The Mails come to the wrong place.

I start the makro and mark the source folder (my inbox) and then i mark the destination folder (new data file empty mailbox)

i stoped the makro on line 78 and then i checked the folder names:
as you see this is a different folder

print subFolder
alt

print subdestfolder
SB

I noticed:
the folder list from my inbox is copied to the "archiv" mailbox without any problems
the program starts to copy from the first folder, but the destination folder is the last one on the "archiv" mailbox
the copy from the second folder comes to the destionation secont to last folder and so on...

should we change the line 78
mItem.move subDestFolder
to
mItem.move subFolder

dlmille

No - because the subFolder is where we're moving from. subDestFolder is keyed at the same time subFolder is keyed, so that should be correct. subFolder is copied one folder down from the selected destination, which is why the index is offset by one on the line assigning subDestFolder. There should be no confusion here.

I tested the code, so at least with my test data everything's falling to the same place.

Assuming you MAY be having corruption problems (or there's something else going on that we haven't considered) PLEASE just create two folders with some subfolders and put mail items in them. Then, archive that. Let me know if this simple test archives correctly.

To be real clear, create a new pst, then move some data to it in different folders, create an Archive folder, then test against this. This should be about as clean a test environment we can do, I believe.

If existing source folders don't (and we don't have a bug) archive correctly, but your tests do, then it could also be a sign of a corrupted .PST or Inbox, etc.

To demonstrate the code is currently correct ->

HMMM- let's try this enhancement to the code - if the subfolder of the source and destination are not the same, you should get a popup notification (see line 63-65):

Option Explicit
Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As MailItem
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

Dim chkTime As Date
Dim iError As Long
Dim iRecords As Long

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        If subFolder.Name <> subDestFolder.Name Then
            MsgBox "This should not be! -> " & subFolder.Name & "," & subDestFolder.Name
        End If
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            On Error Resume Next
            chkTime = mItem.ReceivedTime
            If Err.Number <> 0 Then
                Err.Clear
                chkTime = mItem.CreationTime
            End If
            If Err.Number <> 0 Then
                'MsgBox "Unable to move Mail Item Subject: " & mItem.Subject
                Debug.Print "Unable to move Mail Item Subject: " & mItem.Subject
                iError = iError + 1
            Else
                On Error GoTo 0
                If chkTime <= recDate Then
                    mItem.Move subDestFolder
                End If
            End If
            On Error GoTo 0
            iRecords = iRecords + 1
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete! with " & iError & " Errors out of " & iRecords & " Processed - " & Format(iError / iRecords, "0.00%") & " Error rate"

exitSub:

End Sub
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, fld As MAPIFolder)

Dim subFolder As MAPIFolder


    Folders.Add fld.FolderPath
    EntryID.Add fld.EntryID
    StoreID.Add fld.StoreID

    For Each subFolder In fld.Folders
        GetFolder Folders, EntryID, StoreID, subFolder
    Next subFolder

exitSub:

    Set subFolder = Nothing

End Sub
Function GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            newFolder = chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window

Dave

HelpdeskJBC

ASKER

hey

so i see the problem is this:
When the destination is a new pst (mailbox) im running in that error
but if I use the same pst box as source and destination then everything is fine.

Just one more thing i had to change line 12
Dim mItem As MailItem to dim as Object, because the programm is running in a failure on line 68 "Set mItem = subFolder.Items(j)"
Runtime error 13 Type Missmatch

dlmille

Right. I'll change my version to object as well

Will try on different PSTs and see if I can replicate the problem. I think we just might be there with this discovery

Dave

ASKER CERTIFIED SOLUTION

dlmille

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

HelpdeskJBC

ASKER

Thanks

I used the version before and changed Line 63 - 65 to an yes/no messagebox, because the folder function has problems with foldernames than includes this slash "/"

in the destination it is replaced with %2F
so the source and destination foldername is different ;-)

but its not a big deal, I've already managed to seperate 4 gig of old Mails and until now everything is fine.

HelpdeskJBC

ASKER

Thanks for the Help

dlmille

WOW - that's some great work. Note, my comment on issues moving to/from inbox was invalid as I had a creation time problem with my test data and nothing was being moved because of the time of creation, which should not happen in "real life", though you could modify line 69 (below) to:

chkTime = DateValue(Format(mItem.ReceivedTime,"MM/DD/YYYY"))

Open in new window

Then we are comparing dates to dates, leaving the time of creation out of the equation!

So we have a special character problem with folder names? I made changes to the code to deal with the slash (see line 145), and more replace commands would be needed for other special characters (need to find a list from some resource to be 100% complete):

Option Explicit
Const strSpecialChars = "[,],/,\,&,~,?,*,|,<,>,"",;,:,+" 'find codes for all special characters, and replace accordingly for proper folder creation
Sub ArchiveEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim strFrom As String
Dim strFromEmailAddr As String

Dim iNameSpace As NameSpace
Dim subFolder As MAPIFolder
Dim subDestFolder As MAPIFolder
Dim mItem As Object 'Use object to include all subFolder items
Dim myCopiedItem As MailItem

Dim SourceFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim DestFolder As Object    'late binding with Microsoft Scripting Runtime Library
Dim SourceFolders As New Collection
Dim DestFolders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim EntryIDDest As New Collection
Dim StoreIDDest As New Collection

Dim receivedDate As Variant
Dim recDate As Date

Dim chkTime As Date
Dim iError As Long
Dim iRecords As Long

    receivedDate = InputBox("Enter <= Date for Email Archive", "Enter Date as MM/DD/YYYY", Default:=Format(Now, "MM/DD/YYYY"))
    If receivedDate = vbNullString Then Exit Sub
    On Error Resume Next
    recDate = DateValue(receivedDate)
    If Err.Number <> 0 Then
        MsgBox "Invalid date, please try again"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set iNameSpace = Application.GetNamespace("MAPI")
    
    Set SourceFolder = iNameSpace.PickFolder
    If SourceFolder Is Nothing Then Exit Sub
    
    Set DestFolder = iNameSpace.PickFolder
    If DestFolder Is Nothing Then Exit Sub

    'create collection of Source folders
    Call GetFolder(SourceFolders, EntryID, StoreID, SourceFolder)
    
    'replicate source folder entries into the destination folder
    Call ReplicateFolder(SourceFolder, SourceFolders, DestFolder)
    
    'create collection of Destination folders
    Call GetFolder(DestFolders, EntryIDDest, StoreIDDest, DestFolder)

    For i = 1 To SourceFolders.Count

        Set subFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))
        Set subDestFolder = Application.Session.GetFolderFromID(EntryIDDest(i + 1), StoreIDDest(i + 1))
        
        'MsgBox "Moving: " & vbCrLf & subFolder.folderPath & vbCrLf & " to: " & vbCrLf & subDestFolder.folderPath
        
        For j = subFolder.Items.Count To 1 Step -1
            Set mItem = subFolder.Items(j)
            On Error Resume Next
            chkTime = DateValue(Format(mItem.ReceivedTime, "MM/DD/YYYY"))
            If Err.Number <> 0 Then
                Err.Clear
                chkTime = mItem.CreationTime
            End If
            If Err.Number <> 0 Then
                'MsgBox "Unable to move Mail Item Subject: " & mItem.Subject
                Debug.Print "Unable to move Mail Item Subject: " & mItem.Subject
                iError = iError + 1
            Else
                On Error GoTo 0
                If chkTime <= recDate Then
                    mItem.Move subDestFolder
                End If
            End If
            On Error GoTo 0
            iRecords = iRecords + 1
        Next j
    Next i

    'cleanup
    MsgBox "Process Complete! with " & iError & " Errors out of " & iRecords & " Processed - " & Format(iError / iRecords, "0.00%") & " Error rate"

exitSub:

End Sub
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, fld As MAPIFolder)

Dim subFolder As MAPIFolder


    Folders.Add fld.folderPath
    EntryID.Add fld.EntryID
    StoreID.Add fld.StoreID

    For Each subFolder In fld.Folders
        GetFolder Folders, EntryID, StoreID, subFolder
    Next subFolder

exitSub:

    Set subFolder = Nothing

End Sub
Function GetFolderHandle(fld As MAPIFolder, strFind As String) As MAPIFolder
Dim subFolder As MAPIFolder

    If fld.Name = strFind Then
       Set GetFolderHandle = fld
    Else
        For Each subFolder In fld.Folders
          Set GetFolderHandle = GetFolderHandle(subFolder, strFind)
        Next subFolder
    End If
End Function
Sub ReplicateFolder(srcFld As MAPIFolder, SourceFolders As Collection, destFld As MAPIFolder)
Dim i As Long
Dim rootFolder As String
Dim mainFolder As String
Dim chkFolder As String
Dim newFolder As String
Dim newRoot As String
Dim myTmpFld As MAPIFolder
Dim myFolder As MAPIFolder

    mainFolder = getFileNameAndExt(SourceFolders(1))
    rootFolder = Left(SourceFolders(1), Len(SourceFolders(1)) - Len(mainFolder))
    
    For i = 1 To SourceFolders.Count
        chkFolder = Right(SourceFolders(i), Len(SourceFolders(i)) - Len(rootFolder))
        Call getMainRoot(chkFolder, rootFolder, newFolder, newRoot)

        If rootFolder <> newRoot Then 'get the handle to one folder up from folder to be created
            Set myTmpFld = GetFolderHandle(destFld, newRoot)
        Else 'folder is created off the root
            'deal with special characters
            newFolder = Replace(Replace(Replace(chkFolder, "%2f", "/"), "%2F", "/"), "\\", "") 'chkFolder
            Set myTmpFld = destFld
        End If
        
        If CheckForFolder(myTmpFld, newFolder) = False Then
            'now, create the folder
            Set myFolder = CreateSubFolder(myTmpFld, newFolder)
        End If
        
    Next i

End Sub
Sub getMainRoot(strCheck As String, strOriginalRoot As String, strMain As String, strRoot As String)
    
    If InStr(strCheck, "\") <> 0 Then
        strMain = getFileNameAndExt(strCheck)
        strRoot = getFileNameAndExt(Left(strCheck, Len(strCheck) - Len(strMain) - 1))
    Else
        strMain = strCheck
        strRoot = strOriginalRoot
    End If
        
End Sub
'Adapted from Source: http://www.jpsoftwaretech.com/look-for-and-create-folders-programmatically-in-outlook/
Function CheckForFolder(destFldr As MAPIFolder, strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToCheck As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = destFldr.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(destFld As MAPIFolder, strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")

    Set CreateSubFolder = destFld.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Public Function getFileNameAndExt(strpath As String) As String
Dim tmpStr As String

    If InStr(strpath, "\") <> 0 Then    'has a path
        tmpStr = Right(strpath, InStr(StrReverse(strpath), "\") - 1)
    Else
        tmpStr = strpath
    End If
    
    getFileNameAndExt = tmpStr
End Function

Open in new window

Cheers,

Dave