Outlook Запрет изменения даты модификации писем

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