Solved

Autoarchiving to public folders - Follow up to Q_22913506

Posted on 2012-03-27
6
440 Views
Last Modified: 2013-02-28
Hi All,

This is a followup to Q_22913506 as I need to accomplish the exact same thing. Currently running in an Outlook 2010 / Exchange 2007 environment and I have entered the below script into Outlook. Need to copy emails from within folders or the folder itself to public folders. The path being -
\\Public Folders - First.Last@domain.com\All Public Folders\_TEST

Dim olkArchive As Outlook.MAPIFolder, _
    intAge As Integer

Sub ArchiveFolderTree()
    Dim olkRoot As Outlook.MAPIFolder
    'Change the default age on the following line as desired
    intAge = 10
    'Change the folder path on the following line as needed
    Set olkArchive = OpenOutlookFolder("\\Public Folders - First.Last@domain.com\All Public Folders\_TEST")
    Set olkRoot = Session.GetDefaultFolder(olFolderInbox).Parent
    ArchiveFolder olkRoot, olkArchive
    Set olkRoot = Nothing
    MsgBox "Archive process complete.", vbInformation + vbOKOnly, "Archive Folder Tree"
End Sub

Sub ArchiveFolder(olkSrcFolder As Outlook.MAPIFolder, olkDestFolder As Outlook.MAPIFolder)
    Dim olkSubFolder As Outlook.MAPIFolder, _
        olkArchFolder As Outlook.MAPIFolder, _
        olkItem As Object, _
        varErr As Variant
    On Error Resume Next
    Set olkArchFolder = olkDestFolder.Folders.Item(olkSrcFolder.Name)
    varErr = Err.Number
    On Error GoTo 0
    If varErr <> 0 Then
        Set olkArchFolder = olkDestFolder.Folders.Add(olkSrcFolder.Name, olkSrcFolder.DefaultItemType)
    End If
    For Each olkItem In olkSrcFolder.Items
        If DateDiff("d", olkItem.CreationTime, Now) >= intAge Then
            olkItem.Move olkArchFolder
        End If
    Next
    For Each olkSubFolder In olkSrcFolder.Folders
        ArchiveFolder olkSubFolder, olkArchFolder
    Next
End Sub

Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function

Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        olkFolder As Outlook.MAPIFolder
    On Error GoTo ehOpenOutlookFolder
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        If Left(strFolderPath, 1) = "\" Then
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        End If
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olkFolder) Then
                Set olkFolder = Session.Folders(varFolder)
            Else
                Set olkFolder = olkFolder.Folders(varFolder)
            End If
        Next
        Set OpenOutlookFolder = olkFolder
    End If
    On Error GoTo 0
    Exit Function
ehOpenOutlookFolder:
    Set OpenOutlookFolder = Nothing
    On Error GoTo 0
End Function

On run I am getting a Run-time error '91': Object variable or With block variable not set.
When I select debug it points to this line -

    Set olkArchFolder = olkDestFolder.Folders.Add(olkSrcFolder.Name, olkSrcFolder.DefaultItemType)

What is the reason for this error? how do I fix this?

Your help as always is very appreciated.

Cheers,
Adam
0
Comment
Question by:whitewire
6 Comments
 

Author Comment

by:whitewire
ID: 37779971
Update -  I have corrected the runtime error by removing olkSrcFolder.DefaultItemType from

Set olkArchFolder = olkDestFolder.Folders.Add(olkSrcFolder.Name, olkSrcFolder.DefaultItemType)

Would it be possible to customize this script further by copying not archiving emails so they move from the source folders, copy emails that were delivered within a specific time frame and also only copy emails from specific folders?

I have played around with the intAge As Integer part of the script with no luck, no idea where to start with the remaining.

cheers,
Adam
0
 
LVL 41

Accepted Solution

by:
dlmille earned 500 total points
ID: 37844119
I recently wrote something similar, where you can select first the SOURCE folder then the DESTINATION folder, after specifying a date from which Received/Creation is tested.  It first replicates the folder structure (if it hasn't been already), then moves all mail items from SOURCE to DESTINATION, replicating the folder structure.

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



Test it out and see if you like it.  If you want to do only what the script you posted does, I can look at that, but thought you might be interested in this post as it has a bit more flexibility, re: source/Destination folder and replicating folder structures.

Cheers,

Dave
0

Featured Post

Do email signature updates give you a headache?

Constantly trying to correctly format email signatures? Spending all of your time at every user’s desk to make updates? Want high-quality HTML signatures on all devices, including on mobiles and Macs? Then, let Exclaimer solve all your email signature problems today!

Join & Write a Comment

Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
Follow this checklist to learn more about the 15 things you should never include in an email signature from personal quotes, animated gifs and out-of-date marketing content.
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now