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
Loop
'
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, "\"))
Loop
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)
DoEvents
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
Stop
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
Next
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)
Loop
'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
Next
End If
'Return
the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
|
Comments
Post a Comment