' This script scans through the Outlook mailbox,
' and moves items to the archive based on Received date.
'
'-------------------------------------------------------------------
'
' Copyright 2008, Purdue University, West Lafayette, Indiana, USA
'
' Author: Rex Bontrager
' Creation date: 2008 June 03
'
'-------------------------------------------------------------------
option explicit
RunWithCScript
Const olFolderCalendar = 9
Const olFolderContacts = 10
Const olFolderDeletedItems = 3
Const olFolderDrafts = 16
Const olFolderInbox = 6
Const olFolderJournal = 11
Const olFolderNotes = 12
Const olFolderOutbox = 4
Const olFolderSentMail = 5
Const olFolderTasks = 13
Const olPublicFoldersAllPublicFolders = 18
const iPrimaryExchangeMailbox = 0
Dim OutlookApp : Set OutlookApp = CreateObject("Outlook.Application")
CheckVersion
Dim myNameSpace : Set myNameSpace = OutlookApp.GetNamespace("MAPI")
Dim Mailboxes : Set Mailboxes = myNameSpace.Folders 'same as Stores
dim Stores : Set Stores = OutlookApp.Session.Stores 'same as Mailboxes
dim Store, oFrStore, oToStore, sFr, sTo, CutoffDate, gMoveCnt, BeforeCnt, rc1, rc2
dim olExchangeStoreType
olExchangeStoreType = array("PrimaryExchangeMailbox", _
"ExchangeMailbox", _
"ExchangePublicFolder", _
"NotExchange")
'--set defaults
sFr = ""
sTo = ""
CutoffDate = SetCutoffDate("6 months")
set oFrStore = nothing
set oToStore = nothing
'--parse args
if wscript.Arguments.Count>0 then sFr = wscript.Arguments(0)
if wscript.Arguments.Count>1 then sTo = wscript.Arguments(1)
if wscript.Arguments.Count>2 then CutoffDate = SetCutoffDate(wscript.Arguments(2))
if wscript.Arguments.Count>3 then Bomb "Too many arguments"
on error resume next
if sFr<>"" then set oFrStore=Stores(sFr)
rc1 = err.number
err.clear
if sTo<>"" then set oToStore=Stores(sTo)
rc2 = err.number
if rc1<>0 or rc2<>0 then
if rc1<>0 then say "Arg1 is not a valid mailbox: " & sFr
if rc2<>0 then say "Arg2 is not a valid archive store: " & sTo
say "Valid mailboxes/stores are:"
for each Store in Stores
say " " & Store.DisplayName
next
Bomb ""
end if
if not isDate(CutoffDate) then Bomb "Arg3 is not 'n days' or 'n months'"
on error goto 0
'--select defaults
if oFrStore is nothing or oToStore is nothing then
for each Store in Stores
with Store
'say ""
'say .DisplayName
'say "Application = " & .Application
'say "Class = " & .Class
'say "DisplayName = " & .DisplayName
'say "ExchangeStoreType = " & olExchangeStoreType(.ExchangeStoreType)
'say "FilePath = " & .FilePath
'say "IsCachedExchange = " & .IsCachedExchange
'say "IsDataFileStore = " & .IsDataFileStore
'say "IsInstantSearchEnabled = " & .IsInstantSearchEnabled
'say "IsOpen = " & .IsOpen
'say "Parent = " & .Parent
'say "PropertyAccessor = " & .PropertyAccessor
'say "Session = " & .Session
'say "StoreID = " & .StoreID
if (oFrStore is nothing) and .ExchangeStoreType=iPrimaryExchangeMailbox then
set oFrStore = Store
end if
if (oToStore is nothing) and .IsDataFileStore and inStr(Lcase(.DisplayName & .FilePath), "archive")>0 then
set oToStore = Store
end if
end with
next
end if
'--manually select
if oFrStore is nothing then
set oFrStore = SelectMailbox("Your ACTIVE MAILBOX could not be determined. Please select one:")
if oFrStore is nothing then
Bomb "Cannot determine your active mailbox -- terminating"
end if
end if
if oToStore is nothing then
set oToStore = SelectMailbox("Your ARCHIVE STORE could not be determined. Please select one:")
if oToStore is nothing then
Bomb "Cannot determine your archive store -- terminating"
end if
end if
'--confirm & process
if MsgBox("Ready to archive email that was received on or before " & FrmtDate(CutoffDate) & "." & vbLF & _
"Moving email from """ & oFrStore.DisplayName & """ to """ & oToStore.DisplayName & """" & vbLF & vbLF & _
"Continue?", vbYesNo, "Archive email?")=vbYes then
gMoveCnt = 0
do
BeforeCnt = gMoveCnt
DoTopFolder oFrStore.GetRootFolder, oToStore.GetRootFolder
say ">>> Total moved: " & gMoveCnt
loop until gMoveCnt=BeforeCnt
end if
'OutlookApp.Quit
set OutlookApp = nothing
'end main
sub DoTopFolder (oFrFolder, oToFolder)
if gMoveCnt=0 then
say ""
say "--------------------------------------------"
say " " & oFrFolder.Name
say "--------------------------------------------"
' say "addrbook=" & TopFolder.AddressBookName
' say "app =" & TopFolder.Application
' say "class =" & TopFolder.Class
' say "descrip =" & TopFolder.Description
' say "entryid =" & TopFolder.EntryID
' say "fldrpath=" & TopFolder.FolderPath
' say "inappfld=" & TopFolder.InAppFolderSyncObject
' say "name =" & TopFolder.Name
' say "parent =" & TopFolder.Parent
' say "session =" & TopFolder.Session
' say "storeid =" & TopFolder.StoreID
' say "unread =" & TopFolder.UnreadItemCount
end if
DoFolder oFrFolder.Folders("Inbox"), oToFolder, 1
end sub
sub DoFolder (oFrFolder, oToFolder, Level)
'
' oFrFolder is the "From" folder that is to be checked.
' oFrFolder changes with recursive invocations.
' oToFolder is the high-level destination folder that is
' to receive files and folders from oFrFolder.
' oToFolder is the same for all invocations.
' Level is the subpath depth in oFrFolder being
' processed.
'
dim subfolder, item, arItems, cnt, k
for each subfolder in oFrFolder.Folders
DoFolder subfolder, oToFolder, Level+1
next
'
' Since items are moved from the collection,
' we must collect all the candidate items
' before actually moving them. Otherwise,
' the collection loop gets messed up.
'
redim arItems(oFrFolder.Items.Count) 'index 1 = 1st item
cnt = 0
for each item in oFrFolder.Items
if isCandidate(item) then
cnt = cnt+1
set arItems(cnt) = item
end if
next
if cnt>0 then
say ">>> Folder """ & oFrFolder.Name & """ has " & oFrFolder.Items.Count & " items, moving " & cnt & " items"
end if
for k=1 to cnt
set item = arItems(k)
MoveItem oFrFolder, oToFolder, Level, item
next
end sub
function isCandidate (Item)
dim DT, Subj, rc, rs
on error resume next
''' .CreationTime
''' .ExpiryTime
''' .LastModificationTime
DT = Item.ReceivedTime
''' .ReminderTime
rc = err.number
rs = err.description
Subj = Item.Subject
on error goto 0
if rc<>0 or not isDate(DT) then
' say "Failed to get item's date, rc=" & rc & "=" & rs
' say " " & Subj
isCandidate = false
else
isCandidate = DT<CutoffDate
end if
end function
sub MoveItem (oFrFolder, oToFolder, Level, Item)
dim arFr, oTo, sLevelName, k
'--insure destination folder exists
set oTo = oToFolder
arFr = split(oFrFolder.FolderPath, "\")
for k=1 to Level
sLevelName = arFr(ubound(arFr)-Level+k)
on error resume next
oTo.Folders.Add sLevelName, olFolderInbox 'might already exist
on error goto 0
set oTo = oTo.Folders(sLevelName)
next
'--move item
gMoveCnt = gMoveCnt+1
say gMoveCnt & ": " & FrmtDate(Item.ReceivedTime) & " " & Item.Subject
on error resume next
Item.Move oTo
if err.number<>0 then
say " Move failed, rc=" & err.number & ": " & err.description
end if
on error goto 0
end sub
function SetCutoffDate (sInterval)
'
' sInterval can be "n days" or "n months". The space is optional.
' If valid, returns a DateValue. If invalid, returns null.
'
dim k, quan, unit
quan = 0
unit = ""
for k=1 to len(sInterval)
if not isNumeric(mid(sInterval,k,1)) then exit for
next
quan = left(sInterval,k-1)
unit = Lcase(left(trim(mid(sInterval,k)),1)) 'must be "d" or "m"
if isNumeric(quan) and (unit="d" or unit="m") then
SetCutoffDate = DateValue(DateAdd(unit, -CInt(quan), Now))
else
SetCutoffDate = null
end if
end function
function FrmtDate (Dval)
FrmtDate = right("0" & month(Dval),2) & "/" & right("0" & day(Dval),2) & "/" & year(Dval)
end function
function SelectMailbox (text)
dim indx, Store
set SelectMailbox = nothing
say text
indx = 0
for each Store in Stores
indx = indx+1
say indx & ": " & Store.DisplayName
next
wscript.StdOut.Write "Enter 1-" & Stores.Count & ": "
indx = wscript.StdIn.ReadLine
if isNumeric(indx) then
if CInt(indx)>=1 and CInt(indx)<=Stores.Count then
set SelectMailbox = Stores(CInt(indx))
end if
end if
end function
sub CheckVersion
dim ar
ar = split(OutlookApp.Version, ".")
if CInt(ar(0)) < 12 then
BombLine "This script requires Outlook 2007 or later"
wscript.quit 1
end if
end sub
sub RunWithCScript
'
' Insure that CScript (not WScript) is running
'
dim shell : set shell = CreateObject("wscript.shell")
dim sEngine : sEngine = mid(wscript.FullName,1+InStrRev(wscript.FullName, "\"))
dim sNewCmdLine, arg
if ucase(sEngine)="WSCRIPT.EXE" then
sNewCmdLine = """" & wscript.Path & "\CScript.exe"" //NoLogo """ & wscript.ScriptFullName & """"
for each arg in wscript.Arguments
sNewCmdLine = sNewCmdLine & " """ & arg & """"
next
shell.Run sNewCmdLine
wscript.Quit
end if
end sub
sub Bomb (text)
BombLine text
BombLine ""
BombLine "Syntax: " & wscript.ScriptName & " [mailboxName [archiveName [archiveAge]]]"
BombLine ""
BombLine " where"
BombLine " mailboxName = name of Outlook mailbox"
BombLine " archiveName = name of Outlook archive store"
BombLine " archiveAge = how old an item must be to be archived"
BombLine " (""n days"" or ""n months"")"
BombLine " (default = 6 months)"
OutlookApp.Quit
set OutlookApp = nothing
wscript.quit 1
end sub
sub BombLine (text)
wscript.StdErr.WriteLine wscript.ScriptName & ": " & text
end sub
sub say (text)
wscript.StdOut.WriteLine text
'wscript.StdErr.WriteLine text
end sub |