Outlook archive won't move over files that are flagged for follow up... this routine moves them over- flag intact. (Alpha - use at your own risk)

Outlook archive won't move over files that are flagged for follow up... this routine moves them over- flag intact. (Alpha - use at your own risk) 

There are issues with special folders like syncissues but this seems to work for the most part. There is a loop that waits 5 minutes and repeats Do While (Date + Time) < startup + 30 / 60 / 24 And GblIntRerun > 0 ]

This is for office 365 as files tend to trickle down from the server when doing large moves.

Outlook subroutine to move over all files over x number of days old (Set to 0 by default)

Set objSourceFolder = GetFolderPath("\\[userid]@fieldstoneae.com\")
Set objDestFolder = GetFolderPath("\\[archivename-archive]\")

Watch for Wraps!

Option Explicit
Const Version = "2014-01-12.00"
Dim GBLlngMovedItems As Long
Dim GblIntRerun As Integer
Dim GblStrMsg As String

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long) ''DLL sleep call lets system rest without taxing a for next loop

Sub MoveMail()
    GblIntRerun = 5     ''''''''''''''''''''''''''''''''''''''''''''''''Max number of times to repeat

    Dim objOutlook As Outlook.Application                               ''Outlook
    Dim objNamespace As Outlook.NameSpace                               ''MAPI namespace
    Dim objSourceFolder As Outlook.MAPIFolder                           ''source folder
    Dim objDestFolder As Outlook.MAPIFolder
    Dim objVariant As Variant

    Dim intDateDiff As Integer

    Set objOutlook = Application
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objSourceFolder = GetFolderPath("\\tbanning@fieldstoneae.com") ''objNamespace.GetDefaultFolder(olFolderInbox)
 'Use a folder in a different data file
    Set objDestFolder = GetFolderPath("\\desk014-TJB-WCI-archive")

  If objSourceFolder Is Nothing Or objDestFolder Is Nothing Then
    MsgBox "Cannot find folders.", vbCritical, "Error:"
    Exit Sub
  End If
  If MsgBox("OK to move files from folder " & vbCr & objSourceFolder.FolderPath & vbCr & "TO Folder: & " & _
            vbCr & objDestFolder.FolderPath, vbYesNo + vbQuestion, "WARNING") <> vbYes Then
    Exit Sub
  End If
  Dim startup As Date
  startup = Date + Time
  Do While (Date + Time) < startup + 30 / 60 / 24 And GblIntRerun > 0 ''run for 30 minutes
    MoveMailFolder objSourceFolder, objDestFolder
    Sleep 30 * 1000
    GblIntRerun = GblIntRerun - 1
    If GBLlngMovedItems = 0 Then Exit Do
    ' Display the number of items that were moved.
    MsgBox "Moved " & GBLlngMovedItems & " messages(s).", vbOKOnly, _
           "Started " & Format(startup, "YYYY-MM-DD hh-mm-ssa/p") & " ending " & Format(Date + Time, "YYYY-MM-DD hh-mm-ssa/p")
    If GblStrMsg > "" Then MsgBox GblStrMsg, vbOKOnly, "Errors during move"
Set objDestFolder = Nothing
End Sub

Sub MoveMailFolder(objSourceFolder As folder, objDestFolder As folder)
    Dim intCount As Integer
    Dim objfolder As Outlook.folder
    Dim objTargetFolder As Outlook.folder
    Dim FolderToCheck  As folder
    Dim objVariant, intDateDiff
    Dim npath
    Dim intofold
    'If objSourceFolder.Folders.Count > 0 Then
        For intofold = objSourceFolder.Folders.Count To 1 Step -1
            Set objfolder = Nothing
            Set objfolder = objSourceFolder.Folders(intofold)
            ''npath = Right(objSourceFolder.FolderPath, Len(objSourceFolder.FolderPath) - InStr(3, objSourceFolder.FolderPath, "\"))
            npath = objfolder.FolderPath
            Do While InStr(1, npath, "\") > 0
                npath = Right(npath, Len(npath) - InStr(1, npath, "\"))
            Set objTargetFolder = Nothing
            On Error Resume Next
            Set objTargetFolder = objDestFolder.Folders.Item(npath)
            On Error GoTo 0
            If objTargetFolder Is Nothing Then
                'objfolder.CopyTo objDestFolder                             ''copy to for leaving intact
                'objfolder.MoveTo objDestFolder                             ''move to for cleaning house
                ''Set objTargetFolder = objDestFolder.Folders.Item(npath)   ''used with copy or move options
                On Error Resume Next
                Set objTargetFolder = _
                   objDestFolder.Folders.Add(npath) '' folder type, VarType(objSourceFolder)) ''Create folder based on source type
                   If objTargetFolder Is Nothing Then GblStrMsg = GblStrMsg & vbCr & "Cannot create folder :: " & npath
                On Error GoTo 0
                Exit Sub ''no need to move subs- folder didn't exist- so we moved folder over.
            Else ''folder exists- low-tech move
                MoveMailFolder objfolder, objTargetFolder
            End If
        Next intofold
    'End If ''objSourceFolder.Items.Count > 0

       For intCount = objSourceFolder.Items.Count To 1 Step -1
            Set objVariant = objSourceFolder.Items.Item(intCount)
            intDateDiff = 0
            Select Case LCase(TypeName(objVariant))
                Case "mailitem"
                    intDateDiff = DateDiff("d", objVariant.SentOn, Now)
                    ' adjust number of days as needed.
                Case "contactitem", "taskitem", "distlistitem", "appointmentitem"
                    intDateDiff = DateDiff("d", objVariant.CreationTime, Now)
                Case Else
                    intDateDiff = DateDiff("d", objVariant.SentOn, Now)
            End Select
            If intDateDiff > 0 Then                                     ''condition(s) for move
                objVariant.Move objDestFolder
                'count the # of items moved
                GBLlngMovedItems = GBLlngMovedItems + 1
            End If
End Sub

Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder
    Dim oFolder As Outlook.folder
    Dim FoldersArray As Variant
    Dim i As Integer
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    Do While Right(FolderPath, 1) = "\"
        FolderPath = Left(FolderPath, Len(FolderPath) - 1)
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
    Set GetFolderPath = Nothing
    Exit Function
End Function


Popular posts from this blog

Revit area plans adding new types and references (Gross and rentable)

Organization and management of data in Revit across omniclass, Masterformat, Uniclass, and Uniformat