Post by JimBoy its hard to beleive that there is no automatable method of performing
this time consuming task.
Jim,
I have been watching this post to see how it comes out, I thought this
would be a usefull script. I took a look at the link you provided and
had a look at the script. I ran the beast and sure enough, it did nothing
for me as well. I decided to see where it was busticated. The big
problem seems to be the mail item validation. For some reason
it is checking for "not equal to" when it should be "equal to"
I also did not like the fact that it wacked all my personal folders
from my Outlook profile, so I commented that stuff out.
Watch for line WRAP !! , and just an FYI, I put in a bunch
more echo's so I could figure out what was going on.
This script works fine for me now on WinXP/SP2, with Outlook2003.
' ==================================================================
Option explicit
Dim olApp
Dim olNameSPace
Dim inbox
Dim myfolder
Dim pAItems
Dim archive
Dim newarchive
Dim startDate
Dim endDate
Dim fs
Dim rootStoreID
Dim archStoreID
Dim newarchStoreID
Dim archFileName
Dim newarchFileName
Dim oArgs
Dim x
Dim temp
Const olFolderCalendar = 9
Const olFolderInbox = 6
Const mailItemClass = 43
Const olMailItem = 0
Set oArgs = Wscript.Arguments
If oArgs.Count < 3 Then
WScript.Echo "USAGE: PSTSplitter.vbs <startdate> <enddate> <pstfile>
[newfilename]"
WScript.Echo "Example: PSTSplitter.vbs 1/1/2000 12/31/2000 q:\archive.pst
q:\newarchive.pst"
WScript.Echo ""
WScript.Echo "Note: If newFileName is not specified, a new filname will
automatically"
WScript.Echo " be generated"
WScript.Quit
End If
WScript.Echo "Defining date ranges..."
startDate = DateValue(oArgs(0))
WScript.Echo "Start Date: " & startDate
endDate = DateValue(oArgs(1))
WScript.Echo "End Date: " & endDate
archFileName = oArgs(2)
If startDate > endDate Then
WScript.Echo "INVALID: Start date is after end date"
WScript.Quit 1
End If
Set olApp = CreateObject("Outlook.Application")
Set olNameSpace = olApp.GetNameSpace("MAPI")
rootStoreID = olNameSpace.GetDefaultFolder(olFolderInbox).parent.storeId
Set fs = CreateObject("Scripting.FileSystemObject")
If NOT fs.FileExists(archFileName) Then
WScript.Echo "Archive file doesn't exist"
WScript.Echo "Make sure the path to the .pst file contains no spaces"
WScript.Quit 1
End If
If oArgs.Count = 4 Then
' === New archive name was specified.
newarchFileName = oArgs(3)
Else
' === Generate a filename for new archive.
newarchFileName = genNewFilename(archFileName, oArgs(0), oArgs(1))
End If
WScript.echo "Current Archive: " & archFileName
WScript.echo "New Archive: " & newarchfilename
'WScript.echo "Closing any opened .pst file to avoid conflict"
'Dim i, temp
'For i = olNameSpace.Folders.count To 1 Step -1
' temp = olNameSpace.Folders(i).storeID
' If Left(temp,75) <> Left(rootStoreID,75) Then
' ' === At least the first 75 digits of the rootStoreID
' ' are the same for items that aren't Personal Folders.
' ' Since they're not equal, this must be a
' ' Personal Folder. Close it.
' olNameSpace.RemoveStore olNameSpace.Folders(i)
' End If
'Next
Wscript.echo vbCrLf & "Opening .pst files"
olNameSpace.AddStore archfilename
Wscript.echo vbCrLf & "Setting archive .."
For x = olNameSpace.Folders.count To 1 Step -1
temp = olNameSpace.Folders(x).storeID
If Left(temp,75) <> Left(rootStoreID,75) Then
' === This must be the old archive. Save the storeID
' and reference to the MAPIFolder instance.
Set archive = olNameSpace.Folders(x)
WScript.Echo "Archive set to : " & olNameSpace.Folders(x).Name
archStoreID = temp
End If
Next
olNameSpace.AddStore newarchfilename
Wscript.echo vbCrLf & "Setting New archive .."
For x = olNameSpace.Folders.count To 1 Step -1
temp = olNameSpace.Folders(x).storeID
' === We need to get the reference to the MAPIFolder instance
' of the new .pst file by looking for .pst files currently
' opened in Outlook (using AddStore). We also need to make
' sure that this storeID isn't the same as the one for
' the old archive, or we will be referencing the old
' archive rather than the new one.
If (Left(temp,75) <> Left(rootStoreID,75)) AND (temp <> archStoreID) Then
Set newarchive = olNameSpace.Folders(x)
WScript.Echo "New Archive set to : " & olNameSpace.Folders(x).Name
newarchStoreID = temp
End If
Next
WScript.Echo vbCrLf & "PST To archive from : " & vbTab & archive
WScript.Echo "PST To archive to : " & vbTab & newarchive
createFolders archive, newarchive, startDate, endDate
WScript.Echo "Closing .pst files"
'olNameSpace.RemoveStore archive
'olNameSpace.RemoveStore newarchive
WScript.Echo "SUGGESTION: open up the old archive in Outlook and compact it
" & _
"to reclaim the lost space"
WScript.Quit 0
Sub createFolders(root, newarch, sDate, eDate)
Dim rootNS
Dim rootFolders
Dim newRoot
Dim subRoot
Dim newSubRoot
Dim i
Dim j
Set rootNS = root
Set rootFolders = root.Folders
Set newRoot = newarch
WScript.Echo "Checking archive status for " & rootNS.Items.Count & " items
from " & rootNS.Name & " ..."
For j = rootNS.Items.Count to 1 Step -1
WScript.Echo "Checking " & rootNS.Items(j).Subject
IF (rootNS.Items(j).CreationTime > sDate) AND
(rootNS.Items(j).CreationTime < eDate) AND (rootNS.Items(j).Class =
mailItemClass) Then
' === This item is within the start and end dates.
WScript.Echo "Moving " & rootNS.Items(j).Subject
rootNS.Items(j).Move newRoot
If Err.number > 0 Then
WScript.Echo "Error: " & Err.Description
End If
End If
Next
If rootFolders.Count = 0 Then
' === Stop condition reached
Exit Sub
End If
On Error Resume Next
For i = 1 to rootFolders.count
Set subRoot = rootNS.Folders(i)
WScript.Echo vbCrLf & "Processing Folder : " & rootNS.Folders(i).Name
If subRoot.DefaultItemType = olMailItem Then
' === Create the folder in the new archive
WScript.Echo "Creating " & subRoot
newRoot.Folders.add("" & subRoot)
' === Set the current subfolder in the new archive
' to the newly created folder above.
Set newSubRoot = newRoot.Folders("" & subRoot)
WScript.Echo subRoot & " " & subRoot.items.count
If subRoot.class = 2 Then
' === This is a MAPIfolder. Call this
' subroutine with the root and newroot as
' the current subdirectories.
createFolders subRoot, newSubRoot, sDate, eDate
End If
End If
Next
End Sub
Function genNewFilename(str, sDate, eDate)
sDate = replaceText(sDate,"/","")
sDate = replaceText(sDate,"\\","")
eDate = replaceText(eDate,"/","")
eDate = replaceText(eDate,"\\","")
Dim pos, tempname
pos = InStr(1,str,".pst",1)
If pos <> 0 Then
tempname = Left(str,pos-1)
Else
tempname = str
End If
genNewFilename = tempname & "_" & sDate & "_" & eDate & ".pst"
End Function
Function ReplaceText(str1, oldstr, newstr)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = oldstr
regEx.IgnoreCase = True
regEx.Global = True
ReplaceText = regEx.Replace(str1,newstr)
End Function
TDM