I've got a VB script (from here). I'm looking for some help because I'm not sure how to make it only archive mail that is older than a given number of days and to output to a log file instead of a message box.
Can I just replace all the "msg" lines with "fso"?
What do y'all think? Possible?
Can I just replace all the "msg" lines with "fso"?
What do y'all think? Possible?
'' ExMBspanPst.vbs '' '' Based on a script from Glen Scales '' http://gsexdev.blogspot.com/2007/01/exporting-mailbox-larger-then-2-gb-and.html '' '' Requires Outlook Redemption, but not Outlook '' http://www.dimastr.com/redemption '' '' Fixes a few bugs: '' orig. script didn't split at 16K messages in a folder '' orig. script didn't report progress in 2, 3, ... n PSTs '' orig. script could create two copies of a message in output PST '' orig. script didn't send all status output to output file '' orig. script didn't check for the presence of existing PST '' Adds a feature or two: '' accepts input mailbox as parameter '' a number of stability improvements (error checks) '' added "option explicit" and updated code for support of same '' copies HiddenItems (Associated Items) and DeletedItems as well as normal items '' Almost a full source reformat (so I could understand the code better) '' Removed a fair bit of unused code (although I may have added more of my own) '' Release resources whenever possible '' Use RDO for all things, don't fall back to CDO '' '' Update published with permission of Glen. '' '' Michael B. Smith '' The Essential Exchange '' [email protected] '' Option Explicit Dim mbMailbox '' name of the mailbox (Exchange alias/mailNickname works best) Dim servername '' name of the Exchange server hosting the mailbox Dim bfbaseFilename '' prefix used to name the new PST Dim pfFilePath '' directory in which to store PSTs mbMailbox = WScript.Arguments(0) '' '' these should be the only values you need to change '' servername = "pexn001" bfBaseFilename = "set1-" & mbMailbox pfFilePath = "h:\pst\test\" '' '' end change area '' Dim fnFileName '' name of the output PST (set by CreatenewPst; uses pfFilePath, bfBasefileName and mbMailbox) Dim fNumber '' index of the output PST (will be updated to start at 1 by CreateNewPst) fnFileName = "" fNumber = 0 Dim doDictionaryObject '' scripting.dictionary, contains list of entry-ids present in current PST Dim fso '' scripting.filesystemobject Dim RDOSession '' redemption.rdosession Set doDictionaryObject = CreateObject("Scripting.Dictionary") Set fso = CreateObject("Scripting.FileSystemObject") set RDOSession = CreateObject("Redemption.RDOSession") Dim tsize '' the next time I report the size of the new PST (that is, it's calculated size) Dim tnThreshold '' maximum size (in MB) of a PST, before I switch to a new one tsize = 10 tnThreshold = 1800 Dim PST Dim IPMRoot Dim pfPstFile '' object for the new PST Dim PstRootFolder '' object pointing to the root of the current PST PST = Empty '' PST is the Redemption pointer to the PST IPMRoot = Empty '' IPMRoot is the root of the IPM subtree in the mailbox pfPstFile = Empty '' fso.GetFile(fnFileName) returns the object for this file PstRootFolder = Empty '' This variable never actually gets set, but removing it would've '' called for refactoring too much code - when the code is fixed '' to set this value properly, other stuff breaks. That's why the '' return values are commented out in ProcessFolder[Root | Sub]. Dim wfile '' file we write to for informational messasges Dim dfDeletedItemsFolder '' the deleted items folder in the current input mailbox Dim miLoop '' used for looping through IPMRoot.Folders Dim fld '' used for looping through IPMRoot.Folders Dim iMessageCount '' total number of messages processed iMessageCount = 0 '' '' MAIN code '' On Error Resume Next Set wfile = fso.opentextfile(pfFilePath & bfBaseFilename & ".txt", 2, true) If Err Then WScript.Echo "Main: Error: Could not open " & pfFilePath & bfBaseFilename & ".txt" WScript.Quit 1 End If On Error Goto 0 msg "Main: debug output text file is " & pfFilePath & bfBaseFilename & ".txt" msg "Main: will attempt login to mailbox " & mbMailbox & " on server " & servername RDOSession.LogonExchangeMailbox mbMailbox, servername Set dfDeletedItemsFolder = RDOSession.GetDefaultFolder(3) Call CreateNewPst msg "Main: Enumerating Mailbox " & wscript.arguments(0) For miLoop = 1 to IPMRoot.Folders.Count Set fld = IPMRoot.Folders(miLoop) Call ProcessItems(fld) If fld.Folders.count > 0 then msg "Main: Calling Enumfolders for " & fld.Name Call Enumfolders(fld, PstRootFolder, 2) End if Set fld = Nothing Next msg "Main: A total of " & iMessageCount & " messages were processed." msg "Main: Done" '' clean up and release resources Set dfDeletedItemsFolder = Nothing RDOSession.Logoff wfile.Close Set wfile = Nothing Set RDOSession = Nothing Set fso = Nothing Sub msg(ByVal str) WScript.Echo str wfile.WriteLine(str) End Sub Function Enumfolders(FLDS, RootFolder, ltype) '' '' The current folder in the source mailbox is FLDS '' RootFolder should be the parent folder of the current folder '' '' If ltype == 2, then process the non-folder items in the current folder (i.e., messages) '' If ltype == 1, then process the sub-folders in the current folder '' Dim fl '' used for looping through FLDS.Folders Dim fld '' used for looping through FLDS.Folders For fl = 1 to FLDS.Folders.count Set fld = FLDS.Folders(fl) If ltype = 1 then Call ProcessFolderSub(fld, RootFolder) Else Call ProcessItems(fld) End If msg "Enumfolders: " & fld.Name If fld.Folders.Count <> 0 then Call Enumfolders(fld, fld.EntryID, ltype) End if Set fld = Nothing Next End function Function CreateNewPst '' '' conceivably, we should check ERR.number for almost every statement in this routine '' realistically, that would make the code almost unreadable and incomprehensible '' Dim pstfld '' used for looping through PstRoot.Folders Dim fiLoop '' used for looping through IPMRoot.Folders Dim fld '' used for looping through IPMRoot.Folders doDictionaryObject.RemoveAll fNumber = fNumber + 1 fnFileName = pfFilePath & bfBaseFilename & "-" & fNumber & ".pst" msg "CreateNewPst: About to create new PST named " & fnFileName If fso.FileExists(fnFileName) Then msg "CreateNewPst: Error: PST already exists: " & fnFileName WScript.Quit 1 End If If Not IsEmpty(PST) Then Set PST = Nothing End If Set PST = RDOSession.Stores.AddPSTStore(fnFileName, 1, "Exported MailBox-" & now()) If fnumber = 1 Then Dim pstroot Set pstroot = RDOSession.GetFolderFromID(PST.IPMRootFolder.EntryID, PST.EntryID) For Each pstfld In PstRoot.folders If pstfld.Name = "Deleted Items" Then doDictionaryObject.add dfDeletedItemsFolder.EntryID, pstfld.EntryID msg "CreateNewPst: Added Deleted Items Folder to dictionary" Exit For End If Next Set pstroot = Nothing End If If Not IsEmpty(IPMRoot) Then Set IPMRoot = Nothing End If Set IPMRoot = RDOSession.Stores.DefaultStore.IPMRootFolder msg "CreateNewPST: processing each new default folder in new PST" For fiLoop = 1 to IPMRoot.Folders.count Set fld = IPMRoot.Folders(fiLoop) If fld.Name <> "Deleted Items" Then PstRootFolder = ProcessFolderRoot(fld, PST.IPMRootFolder.EntryID) End If If fld.Folders.count > 0 Then Call Enumfolders(fld, fld.EntryID, 1) End If Set fld = Nothing Next If Not IsEmpty(pfPstFile) Then Set pfPstFile = Nothing End If Set pfPstFile = fso.GetFile(fnFileName) tsize = 10 '' back at the beginning now msg "CreateNewPst: Created new PST named: " & fnFileName End Function Function ProcessFolderRoot(Fld, parentfld) Dim newFolder '' next folder to be examined Dim CDOPstFld '' a particular folder parent in the PST based on the entryid of the PST msg "ProcessFolderRoot: " & fld.Name Set CDOPstfld = RDOSession.GetFolderFromID(parentfld, PST.EntryID) Set newFolder = CDOPstfld.Folders.ADD(Fld.Name) '''ProcessFolderRoot = newFolder.EntryID newfolder.fields(&H3613001E) = Fld.fields(&H3613001E) doDictionaryObject.add Fld.EntryID, newfolder.EntryID Set newFolder = Nothing Set CDOPstfld = Nothing End Function Function ProcessFolderSub(Fld, parentfld) Dim newFolder '' next folder to be examined Dim CDOPstFld '' a particular folder parent in the PST based on the entryid of the PST msg "ProcessFolderSub: " & fld.Name Set CDOPstfld = RDOSession.GetFolderFromID(doDictionaryObject.item(parentfld), PST.EntryID) Set newFolder = CDOPstfld.Folders.ADD(Fld.Name) '''ProcessFolderSub = newFolder.EntryID newfolder.fields(&H3613001E) = Fld.fields(&H3613001E) doDictionaryObject.add Fld.EntryID, newfolder.EntryID Set newFolder = Nothing Set CDOPstfld = Nothing End Function Sub ReportError(prefix, Fld, item, txt) msg prefix & " " & "Error Processing Item #" & item & " in " & Fld.Name & " " & txt msg prefix & " " & "EntryID of Item: " & Fld.items(item).EntryID msg prefix & " " & "Subject of Item: " & Fld.items(item).Subject End Sub