' 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 |