Office 2007 upgrade & autoarchive problems

 Synopsis of problem:

Autoarchive quits working on users' mailboxes "all of a sudden". Investigation reveals that all messages have a single modified timestamp that does NOT coincide with an actual time of response or forwarding. Autoarchiving starts functioning as advertised *PAST* the modification timestamp. Manual archive does not work either, because it is based on the same settings.

Synopsis on how autoarchive works:

 Autoarchive looks at the modify timestamp (found under "message properties") of each message. If the modify date is prior to the autoarchive date, the message is moved out from the active mailbox to the user's set archive pst file.

Presumably, the rationale of having modify vs. created/received date is that it updates the modified-stamp if you reply to or forward an old message, thereby keeping it "active".

Potential (conjectured) cause:

We suspect that when Office gets upgraded from one version to the other, it upgrades the .ost file from one format to the next. Updating the ost file probably resets the modify date on every message. Once you go online, it probably updates the main message store with the "new" modify timestamp, and therefore breaks autoarchive.  Pst files work a bit differently than ost- pst updates do NOT change modify time, but ost updates do.

Another newly discovered interaction has to do with McAfee AV potentially scanning and touching modify time of certain messages.

 
Potential solution*:

 When upgrading Outlook users' laptops- try to disable offline folders first. This requires a restart of Outlook. Then upgrade Outlook, then enable offline folders again... see if this avoids the problem to begin with. Again, those steps are:

1. Open Outlook, old version.

2. Disable offline folders and/or cached exchange mode if enabled.

3. Close outlook, wait 15 sec, reopen Outlook, wait 15 sec, close Outlook.

4. Upgrade.

5. Open Outlook, enable offline folders and/or cached exchange mode,  have the user wait for the ost to populate.

 
*: This solution has not even been tried, let alone tested, but it seems to me that this is one of the only ways to work around the limitations.

 Of course, given that we cannot predict who this will happen to, it is a lot of work to go through, with not very much to show for it after the fact.

Update:

As of June 13th, 2008, we are working on a script that will allow autoarchive based on receive date instead of modify date. More information as we proceed.

As of July 9th, 2008, we have a script that will allow autoarchiving of 1500 items or less based on receive date. More testing to follow.

As of November 3rd, our script is still unable to break the 1500 item barrier, active work on this script has been shelved until a later date.

As of November 18th, 2008, a breakthrough! We will post a copy of the script here shortly.

This script is intended to be run on NON-ECN MACHINES ONLY! This script is provided AS-IS as-is, with no implied warranty... Do not redistribute without the copyright notice at the header. If this script does what you need it to do, please drop us a thank-you email saying so!!

If you are using an ECN supported machine, please contact your site specialist instead of using this script.

Contents of script file ArchiveOutlookByReceivedDate.vbs

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