?
Solved

Autoarchiving to public folders - Follow up to Q_22913506

Posted on 2012-03-27
6
Medium Priority
?
476 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
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 42

Accepted Solution

by:
dlmille earned 2000 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

Problems using Powershell and Active Directory?

Managing Active Directory does not always have to be complicated.  If you are spending more time trying instead of doing, then it's time to look at something else. For nearly 20 years, AD admins around the world have used one tool for day-to-day AD management: Hyena. Discover why

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes how to import Lotus Notes Contacts into Outlook 2016, 2013, 2010 and 2007 etc. with a few manual steps. You can easily export and migrate Lotus Notes contacts into Microsoft Outlook without having to use any third party tools.
If you need to forecast numbers -- typically for finance -- the Windows and Mac versions of Excel 2016 have a basket of tools to get the job done.
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…
This is my first video review of Microsoft Bookings, I will be doing a part two with a bit more information, but wanted to get this out to you folks.
Suggested Courses
Course of the Month11 days, 11 hours left to enroll

752 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