How To Archive Emails of EVERYONE by year?

Ah also, no I don't want to create "archive folders" inside the Inbox structure! I need it to be OFF of the exchange server they are connecting to! As I said, I don't have an exchange server, but users are connecting to one via their Outlook clients. the admin in charge has told me that he won't tolerate 1.6GB mailboxes any longer... which is also why I am sort of now forced to do it this way.

Hi ITKnightMare,

I might be able to help with this.  I will need a few more details to make sure I understand how this is supposed to work before I can say for sure.  If I can, then I can write something in VB6, VBScript, or VBA (you're choice).  Will this be a process that's running all the time, or at set intervals?  If intervals, how often?  Do I understand correctly that it will look through the Inbox and move messages meeting a date condition to a PST file?  Would that PST already exist or would it need to create it?

Cheers!

Q#1) Will this be a process that's running all the time, or at set intervals?  If intervals, how often?

I would prefer to run it all the time of course, but I suppose worst-case we can run it monthly or something. The idea is to keep it neat and clean.

Q#2)  Do I understand correctly that it will look through the Inbox and move messages meeting a date condition to a PST file?

Exacto Mundo! Precisely!! :) The date condition is: yearly!

Q#3) Would that PST already exist or would it need to create it?

It would need to be created and appended on thereafter.

BlueDevilFan:

Are you there my friend? I really need an answer to this ASAP :/

Thnx,

Those two website are my favorites in finding scripts, and tips:

http://www.outlookforms.com/
http://www.outlook-tips.net/index.html

I'm not expert in scripting, but those links are helpfull.

Good luck,

Naser

ITKnightMare,

I'm here.

Here's the code.  Right now the code reads through the Inbox and moves all unread mail items, not task requests, read receipts, meeting requests, etc., to a PST file created to hold messages for the year the message was received in.  Messages received in 2005 will move to the 2005 folder, 2006 messages to the 2006 folder and so forth.  If the PST file doesn't exist, then the code creates it automatically.  The PST files are opened/closed dynamically so the user doesn't really see them.  Right now the code will only run manually.  I can make a change so it'll run every time Outlook starts or shuts down.  I could possibly modify it to run at a certain time each day also.  The code is designed to run inside Outlook, but I can modify it to run outside of Outlook.  That would allow you to set this up as a scheduled task that could run however often you want.  I tested the code on my system (Outlook 2003) and it worked properly.

Do you need instructions on how to set a macro up in Outlook?

Sub ArchiveMessagesByYear()
    'Change the file path on the next line to that of the folder where you want the PST file to be stored.
    Const ARCHIVE_FILE_PATH = "C:\eeTesting\"
    Dim objFSO As Object, _
        olkSourceFolder As Outlook.MAPIFolder, _
        olkArchiveFolder As Outlook.MAPIFolder, _
        olkItem As Object, _
        olkNS As Outlook.NameSpace, _
        strArchiveFileName As String, _
        strYear As String, _
        intItem As Integer
    Set olkNS = Application.GetNamespace("MAPI")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set olkSourceFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    For intItem = olkSourceFolder.Items.Count To 1 Step -1
        Set olkItem = olkSourceFolder.Items.Item(intItem)
        If olkItem.Class = olMail Then
            If olkItem.UnRead = False Then
                strYear = Year(olkItem.ReceivedTime)
                strArchiveFileName = ARCHIVE_FILE_PATH & strYear & ".pst"
                If Not objFSO.FileExists(strArchiveFileName) Then
                    CreateYearlyPST strYear, strArchiveFileName
                End If
                olkNS.AddStore strArchiveFileName
                Set olkArchiveFolder = OpenMAPIFolder("\" & strYear & "\Inbox")
                olkItem.Move olkArchiveFolder
                olkNS.RemoveStore olkArchiveFolder
            End If
        End If
    Next
    Set olkSourceFolder = Nothing
    Set olkArchiveFolder = Nothing
    Set olkItem = Nothing
    MsgBox "All done!"
End Sub

Sub CreateYearlyPST(strYear As String, strArchiveFileName As String)
    Dim olkNS As Outlook.NameSpace, _
        olkFolder As Outlook.MAPIFolder
    Set olkNS = Application.GetNamespace("MAPI")
    olkNS.AddStore strArchiveFileName
    Set olkFolder = OpenMAPIFolder("\Personal Folders")
    olkFolder.Folders.Add "Inbox", olFolderInbox
    olkFolder.Name = strYear
    olkNS.RemoveStore olkFolder
    Set olkFolder = Nothing
    Set olkNS = Nothing
End Sub

'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
    Else
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
End Function

Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function

Is this for vb6? or vbs?

also, I need it to run regardless if outlook is open or not

I just got word that I am supposed to have this run via GPO so, it's definitely going to have to be an .exe or .vbs

> Is this for vb6? or vbs?
That version is VBA.  It's easily converted to VB6 or VBS though.  I've posted a VBS version below.

> I need it to run regardless if outlook is open or not
That's going to be a problem.  The user's Outlook profile has to be logged into for any solution to work.  Unless you want the user to put their password into a script, then a login dialog will pop up when the code runs and tries to login.  


    'Change the file path on the next line to that of the folder where you want the PST file to be stored.
    Const ARCHIVE_FILE_PATH = "C:\eeTesting\"
    Dim objFSO, olkSourceFolder, olkArchiveFolder, olkItem, olkApp, olkNS, strArchiveFileName, strYear, intItem
    Set olkApp = CreateObject("Outlook.Application")
    Set olkNS = olkApp.GetNamespace("MAPI")
    'Change the profile name on the following line
    olkNS.Logon "Outlook"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set olkSourceFolder = olkApp.GetNamespace("MAPI").GetDefaultFolder(6)
    For intItem = olkSourceFolder.Items.Count To 1 Step -1
        Set olkItem = olkSourceFolder.Items.Item(intItem)
        If olkItem.Class = olMail Then
            If olkItem.UnRead = False Then
                strYear = Year(olkItem.ReceivedTime)
                strArchiveFileName = ARCHIVE_FILE_PATH & strYear & ".pst"
                If Not objFSO.FileExists(strArchiveFileName) Then
                    CreateYearlyPST strYear, strArchiveFileName
                End If
                olkNS.AddStore strArchiveFileName
                Set olkArchiveFolder = OpenMAPIFolder("\" & strYear & "\Inbox")
                olkItem.Move olkArchiveFolder
                olkNS.RemoveStore olkArchiveFolder
            End If
        End If
    Next
    Set olkSourceFolder = Nothing
    Set olkArchiveFolder = Nothing
    Set olkItem = Nothing
    olkNS.Logoff
    Set olkNS = Nothing
    Set olkApp = Nothing

Sub CreateYearlyPST(strYear, strArchiveFileName)
    Dim olkNS, olkFolder
    Set olkNS = Application.GetNamespace("MAPI")
    olkNS.AddStore strArchiveFileName
    Set olkFolder = OpenMAPIFolder("\Personal Folders")
    olkFolder.Folders.Add "Inbox", 6
    olkFolder.Name = strYear
    olkNS.RemoveStore olkFolder
    Set olkFolder = Nothing
    Set olkNS = Nothing
End Sub

'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
    Else
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
End Function

Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function

BlueDevilFan:

what are the possibilites of doing this in vb6? since it would be an exe, i would feel much safer of putting the users info (username and password) into it. with a vbs it can be opened in notepad :/

--itkm

also I wanto award you the extra 50 i gave u in that other one. go ahead and reply to it so I can :)

also can you tell me how to setup the vba version in outlook?

what i will do is present both ways:

1)vba in outlook
2) vb6 as external

and let them choose!

thnx,

I can easily convert this to VB6.  I'm not sure that's a good solution though.  If we store the password in the executable, then it means having to create a separate exe for every employee.  It would also mean creating a new exe every time an employee changes their password.  I expect that'd be a problem.  If that's the way you want to go though, then I can put the code together.  If you do want to go that route, then I'd recommend encrypting the password and storing it either in a text file or in the registry where it can be changed without having to create a new exe.

Here are the instructions for using this in Outlook (i.e. the VBA approach).  

1.  Start Outlook
2.  Click Tools->Macro->Visual Basic Editor
3.  If not already expanded, expand Modules and click on Module1
4.  Copy the code below and paste it into the right-hand pane of the VB editor window
5.  Edit the code as needed
6.  Click the diskette icon on the toolbar to save changes
7.  Close the VB Editor
8.  Click Tools->Macro->Security
9.  Set the Security Level to Medium

Hi BlueDevilFan:

I definitely would like the vb6 code as well :) and thnx for the instructions for the macro.

Looking forward to the vb6 code.

--ITKnightMare

UPDATE:

Ran the script (VBA) version in outlook. Looks cool but a bit confused.

I need the emails it categorized by year to still appear under "Archive folders". First look is the emails are not there!! Then I realized that it put them all under the pst files in the folder you created for it. That's cool but:

a) I need this years emails to stay in the inbox; anything older than previous years should be categorized under it's appropriate year then STAY in the current Inbox for upto 3 years, and anything OLDER than 3 years should go to Archive folders under it's existing name

b) it didn't get the subfolders. The emails in the subfolders still exist uncategorized.

The reason this creates a problem is because we have people with like (no kidding) 200+ folders in their inboxes... categories by projects, tasks, personal, blablabla

they want to be able to maintain that same structure even after it has moved to archive folders.

thnx and looking forward to the vb6 code.

--ITKnightMare

> still appear under "Archive folders"
Sorry, I dont' follow what you mean.  Are you saying you want all these messages to go into sub-folders in the Archive folder?  I thought you said you didn't want archive folders?  I'm missing something.

> anything older than previous years should be categorized under it's appropriate year then STAY in the current Inbox for upto 3 years
Unless you want to make copies of messages, then it's impossible for an item to be in two places (i.e. categorized under it's proper year, which I assume means in an archive folder, and in the inbox).

> it didn't get the subfolders
That's because I don't remember ever seeing any mention of it needing to process sub-folders.

Hey BlueDevilFan:

My bad. I guess I wasn't clear and for this I apologize. to make it crisp clear:

Scenario:

Bob uses his outlook 2K3 with an outsider exchange server (as in I have no admin control over the exchange account other than connecting users to the server)
Bob is an EXTENSIVE user: as in he has roughly 2GB worth of emails in roughly 200 subfolders. Reason? God knows. But to sum it up a sample screen shot of the HELL I am facing AKA a user's inbox is as follows:

http://www.geocities.com/knightmare_y2k/sample.png 

As you can see I tried to do what I am wanting the script to do. which is, categorize based on year as an archive folder, maintaining the folder/sub-folder structure.

what you provided only strips the inbox and it doesn't attach it as "archive folder" but just leaves the physical pst file in the hdd. I hope I made some sense now...

But the idea is, it will grab a persons inbox+folders+subfolders and move them to archive folders maintaing the structure by year. and the this year + 3 years (06. 05. 04) will stay in Inbox, while ANYTHING OLDER will move to archive folders.

And I need this as a VBA and VB6 :)

Looking forward to your response my friend.

Sincerely,
ITKnightMare

Ok, good explanation, I think I've got it.  This'll require changes to the code both to handle the sub-folders and to file the items in the correct corresponding folder in the PST file.  I'll work on it and be back in touch.  Might be a couple of days.

Here's the revised VBA version.  Let me know if this does what you want it to and then I'll post the VB6 version.

Sub ArchiveMessages()
    ArchiveFolder Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    MsgBox "Archiving complete!"
End Sub

Sub ArchiveFolder(olkFolder As Outlook.MAPIFolder)
    Dim olkSubFolders As Outlook.Folders, _
        olkSubFolder As Outlook.MAPIFolder
    ArchiveMessagesByYear olkFolder
    Set olkSubFolders = olkFolder.Folders
    If olkSubFolders.Count > 0 Then
        For Each olkSubFolder In olkSubFolders
            ArchiveFolder olkSubFolder
        Next
    End If
    Set olkSubFolder = Nothing
    Set olkSubFolders = Nothing
End Sub

Sub ArchiveMessagesByYear(olkSourceFolder As Outlook.MAPIFolder)
    'Change the file path on the next line to that of the folder where you want the PST file to be stored.
    Const ARCHIVE_FILE_PATH = "C:\eeTesting\"
    Dim objFSO As Object, _
        olkArchiveFolder As Outlook.MAPIFolder, _
        olkItem As Object, _
        olkNS As Outlook.NameSpace, _
        strArchiveFileName As String, _
        strYear As String, _
        intItem As Integer
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For intItem = olkSourceFolder.Items.Count To 1 Step -1
        Set olkItem = olkSourceFolder.Items.Item(intItem)
        If olkItem.Class = olMail Then
            If DateDiff("yyyy", olkItem.ReceivedTime, Date) >= 3 Then
                strYear = Year(olkItem.ReceivedTime)
                strArchiveFileName = ARCHIVE_FILE_PATH & strYear & ".pst"
                If Not objFSO.FileExists(strArchiveFileName) Then
                    CreateYearlyPST strYear, strArchiveFileName
                End If
                Set olkNS = Application.GetNamespace("MAPI")
                olkNS.AddStore strArchiveFileName
                Set olkArchiveFolder = OpenMAPIFolder("\" & strYear & "\Inbox")
                olkItem.Move olkArchiveFolder
                olkNS.RemoveStore olkArchiveFolder
                Set olkNS = Nothing
            End If
        End If
    Next
    Set olkArchiveFolder = Nothing
    Set olkItem = Nothing
End Sub

Sub CreateYearlyPST(strYear As String, strArchiveFileName As String)
    Dim olkNS As Outlook.NameSpace, _
        olkFolder As Outlook.MAPIFolder
    Set olkNS = Application.GetNamespace("MAPI")
    olkNS.AddStore strArchiveFileName
    Set olkFolder = OpenMAPIFolder("\Personal Folders")
    olkFolder.Folders.Add "Inbox", olFolderInbox
    olkFolder.Name = strYear
    olkNS.RemoveStore olkFolder
    Set olkFolder = Nothing
    Set olkNS = Nothing
End Sub

'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
    Else
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
End Function

Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function

It gave an error on my test system:

Method 'RecievedTime' of object 'MailItem' failed

I'm not sure how that's possible.  There is no instance of the word "MailItem" anywhere in the code.  

All I did was follow your instructions making it into a macro. and then I said run :)

It waited for a while then gave me that error above.

How about you give me the vb6 code and Ill try it under there. let's see if it gives an error as well? VB6 would be a bit more descriptive.

--ITKM

UPDATE:

I ran it on another computer and same error :/

By the way also wanted to iterate on your comment:

olkItem As Object, is the MailItem Class' object
and olkItem.ReceivedTime is what's giving the error.

--ITKM

So it's this line that the error is occurring on?

    If DateDiff("yyyy", olkItem.ReceivedTime, Date) >= 3 Then

I am assuming so, since that's the only line with the ".RecievedTime" event. :p

By the way, someone suggested instead of locating the items the way you are doing to look here:

***********************************************************************************************
Tell you friend that there's a much easier and more efficient way to locate all the relevant items, using Items.Find or Items.Restrict. See http://www.outlookcode.com/d/finddate.htm for more.
***********************************************************************************************

Maybe the answer is there?

--ITKM

> since that's the only line with the ".RecievedTime" event
No, there are two lines with ReceivedTime

     If DateDiff("yyyy", olkItem.ReceivedTime, Date) >= 3 Then
         strYear = Year(olkItem.ReceivedTime)


> there's a much easier and more efficient way to locate all the relevant items
While I appreciate the suggestion I'm already quite familiar with both Find and Restrict.  I chose not to use them because I find them cumbersome for date fields.  All of this is immaterial though to discovering what's causing the problem.  Using Find/Restrict in place of the itterative loop I'm using affects performance and has nothing to do with why you're getting an error on olkItem.ReceivedTime.   I still have to use ReceivedTime even if I did switch to Restrict.   I thought I remembered from the screenshot you posted that you're using Outlook 2003.  The link is dead now and I can't verify that.  Are you using 2003?  If not, what version are you using?  Also, when you tried running the code what macro name did you launch?  Was it ArchiveMessages?  If not, then please try running that macro.

I am using Outlook 2003

And all I did was follow your instructions to the letter a few posts above. I didn't name it anything it's named by itself.

> all I did was follow your instructions to the letter a few posts above
I looked back at my instructions and don't see where I specified which module to run.  The module you need to launch is "ArchiveMessages".  Click Tools->Macro->Macros, select ArchiveMessages and click Run.

> I didn't name it anything it's named by itself
I know you didn't name it.  I was asking which module you launched.  If it wasn't ArchiveMessages, then that explains the error you're getting.

Nope.

I ran ThisOutlookSession.ArchiveMessages

and the error is STILL the same :/

--ITKM

UPDATE:

As a vb6 programmer, I sort of decided to take this sucker apart and see if I can figure out what the hey is wrong with it.

when I put breeakpoints on this line and added it to the Watch list
            If DateDiff("yyyy", olkItem.ReceivedTime, Date) >= 3 Then

It had no value... And kept going over and over at that line.

when I added:

     Dim bla As String
            bla = olkItem.ReceivedTime

to the beginning of it (still in the if loop) bla had a value.

I tried passing it as :

 If DateDiff("yyyy", bla, Date) >= 3 Then

instead... but no luck there... the error is still the same my friend.

Well, I'm pretty much stumped.  I've run the code here repeatedly and never get an error.  I can't think of any explanation for olkItem.ReceivedTime being empty at that point.  To get that far the code must have found the folder, it must have found that there are one or more items in the folder, it must have read the first item, that item must have been a mail message, and mail messages all have a value in ReceivedTime.  It seems impossible for the field to be blank.  The only suggestion I can offer is to put a breakpoint on this line

    For intItem = olkSourceFolder.Items.Count To 1 Step -1

in the subroutine ArchiveMessagesByYear().  Check all variables and objects and see if they are filled in with proper values.  If they don't appear to be, then report your findings back and we'll take it from there.  If they do appear to be, then step through the code line by line and watch them to see if you can figure out what's happening.  The VB IDE in Outlook works exactly like the one in VB6.  F9 sets a break point, F8 steps to the next line of code, select a variable and right-click on it to set a watch, etc.  

Hey BlueDevilFan:

I went to my boss and told him about the problems we are facing. He said, "OK fine. Stop wasting time on this, we need a solution ASAP. How about this?"

And he gave me a link to a vbs script called "pstsplitter". The problem is the thing is broken (the author was weird) I tried fixing it as much as I can, but it still won't work on ANY pst I give it.

Can you give me a hand with it?

'Web Listing 1: PSTSplitter.vbs
' ==================================================================
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


Const olFolderCalendar = 9
Const olFolderInbox = 6

Const mailItemClass = 43
Const mailDefaultItemType = 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 filename will automatically"
      WScript.ECHO "      be generated"
      Wscript.Quit 1
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 "Opening .pst files"
olNameSpace.AddStore archfilename

For i = olNameSpace.Folders.count To 1 Step -1
      temp = olNameSpace.Folders(i).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(i)
            archStoreID = temp
      End If
Next
olNameSpace.AddStore newarchfilename
For i = olNameSpace.Folders.count To 1 Step -1
      temp = olNameSpace.Folders(i).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(i)
            newarchStoreID = temp
      End If
Next

WScript.Echo vbTab & archive
WScript.Echo 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
      Dim time

      set rootNS = root
      set rootFolders = root.Folders
      set newRoot = newarch
      
      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)

            If subRoot.DefaultItemType <> mailDefaultItemType 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

Or could you modify yours to work with just the pst files instead of the active AND pst?

as either a vba or vbs or vb6

and finally I have gotten pretty late so at this point I am even willing to pay cash if you want me to. I am really desperate and the meeting this morning was not fun (having to cringe and say I couldn't find a solution) :/

ITKnightMare,

I'll take a look at it, but I don't know how quick and I can fix whatever's wrong and get it working.  I work on questions in the evenings after work and for a few minutes in the morning before work.  Sometimes I have work things to do and don't have time for questions.  My point is that I can't predict how much time I'm going to have and therefore can't say how quick I can get something done.  It's also possible that the script will work for me, as mine does, and not for you, as mine doesn't.  I appreciate the offer of cash, but that's not why I do this and it wouldn't change the amount of time I have to work on things.  Let me have a look and I'll get back to you.

Ok, I ran the script a couple of times and it's clearly not working properly.  It makes the PST file and creates folders in it, but doesn't seem to copy any items over, no matter what date range I give it.  Is that the same behavior you experienced?  I won't have much time to look at it tomorrow during the day, but will see what I can do tomorrow night.  I can't promise anything, but will see what progress I make.  Will keep you posted on where I am with this.

:) That's precisely what I am experiencing. Indeed if you can fix it that would be great!

Looking forward to your answer my friend (give the ol' BDF touch! add your magic into it hehehe)

--ITKM

Ok, try this.  I ran it a few times and it seems to work properly.  It does spit out errors sometimes, but still seems to move the messages.  I'll try and figure out where the errors are coming from later, but at the moment this is all I had time for.

'Web Listing 1: PSTSplitter.vbs
' ==================================================================
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


Const olFolderCalendar = 9
Const olFolderInbox = 6

Const mailItemClass = 43
Const mailDefaultItemType = 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 filename will automatically"
     WScript.ECHO "      be generated"
     Wscript.Quit 1
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 "Opening .pst files"
olNameSpace.AddStore archfilename

For i = olNameSpace.Folders.count To 1 Step -1
     temp = olNameSpace.Folders(i).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(i)
          archStoreID = temp
     End If
Next
olNameSpace.AddStore newarchfilename
For i = olNameSpace.Folders.count To 1 Step -1
     temp = olNameSpace.Folders(i).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(i)
          newarchStoreID = temp
     End If
Next

WScript.Echo vbTab & archive
WScript.Echo vbTab & newarchive

createFolders archive, newarchive, startDate, endDate

WScript.Echo "Closing .pst files"

olNameSpace.RemoveStore archive
olNameSpace.RemoveStore newarchive
Set olNameSPace = Nothing
Set olApp = Nothing
Set fs = Nothing
WScript.Echo "SUGGESTION: open up the old archive in Outlook and compact it " & _
          "to reclaim the lost space"
WScript.Quit 0

Sub createFolders(objArchive, objNewArchive, sDate, eDate)
      Dim objSubFolders, objSubFolder, j, objNewFolder
      On Error Resume Next
      For j = objArchive.Items.Count To 1 Step -1
            'WScript.Echo "Date Check: " & FormatDateTime(objArchive.Items.Item(j).CreationTime,2) & " " & sDate & " " & eDate & " " & objArchive.Items.Item(j).Class
            If (CDate(FormatDateTime(objArchive.Items.Item(j).CreationTime,2)) >= CDate(sDate)) And (CDate(FormatDateTime(objArchive.Items.Item(j).CreationTime,2)) <= CDate(eDate)) And (objArchive.Items.Item(j).Class = mailItemClass) Then
                  WScript.Echo "Moving: " & objArchive.Items.Item(j).Subject
                  objArchive.Items.Item(j).Move objNewArchive
                  If Err.number <> 0 Then
                  WScript.Echo "Error #" & Err.number & " - "& Err.Description
            End If
            End If
      Next
      Set objSubFolders = objArchive.Folders
    If objSubFolders.Count = 0 Then
          ' === Stop condition reached
        Exit Sub
    End If
      For Each objSubFolder In objSubFolders
            WScript.Echo "Processing SubFolder: " & objSubFolder.Name
            Set objNewFolder = objNewArchive.Folders.Add(objSubFolder.Name)
            createFolders objSubFolder, objNewFolder, sDate, eDate
    Next
    On Error Goto 0
    Set objNewFolder = Nothing
    Set objSubFolder = Nothing
    Set objSubFolders = Nothing
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

Wow this does do the trick :) If you can indeed perfect it so no more errors come thru, then you get teh points for this plus the extra my friend!!

--ITKM

Hey BDF... Are you around? Have you been able to check out why it gives the Error #13: Type Mismatch errors?

--ITKM

EUREKA!!! YOU ARE AWESOME BDF :)

Now... would it be too much to ask if you can convert it to vb6 for me? I can make another thread for this request and give you another 500 points if you like!

--ITKM

ITKM,

I haven't forgotten this.  I'm working to convert it to VB6.

Here's the VB6 code.  It doesn't use a form.  Create a BAS module and insert the code.  

Option Explicit
Option Base 1

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 arrArgs

Const olFolderCalendar = 9
Const olFolderInbox = 6

Const mailItemClass = 43
Const mailDefaultItemType = 0


Sub Main()
    arrArgs = Split(Command(), "-")

    If UBound(arrArgs) < 3 Then
        MsgBox " USAGE: PSTSplitter.exe -<startdate> -<enddate> -<pstfile> -[newfilename]" & vbCrLf _
            & "Example: PSTSplitter.exe -1/1/2000 -12/31/2000 -q:\archive.pst -q:\newarchive.pst" & vbCrLf _
            & vbCrLf _
            & "Note: If newfilename is not specified, a new filename will automatically be generated.", vbCritical + vbOKOnly, "PSTSplitter"
        End
    End If

    Debug.Print "Defining date ranges..."
    startDate = DateValue(arrArgs(1))
    Debug.Print "Start Date: " & startDate
    endDate = DateValue(arrArgs(2))
    Debug.Print "End Date: " & endDate
    archFileName = arrArgs(3)

    If startDate > endDate Then
        MsgBox "INVALID: Start date is after end date", vbCritical + vbOKOnly, "PSTSplitter"
        End
    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
        MsgBox "Archive file doesn't exist" & vbCrLf _
            & "Make sure the path to the .pst file contains no spaces", vbCritical + vbOKOnly, "PSTSplitter"
        End
    End If

    If UBound(arrArgs) = 4 Then
        ' === New archive name was specified.
        newarchFileName = arrArgs(4)
    Else
        ' === Generate a filename for new archive.
        newarchFileName = genNewFilename(archFileName, arrArgs(1), arrArgs(2))
    End If

    Debug.Print "Current Archive: " & archFileName
    Debug.Print "New Archive: " & newarchFileName

    Debug.Print "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

    Debug.Print "Opening .pst files"
    olNameSPace.AddStore archFileName

    For i = olNameSPace.Folders.Count To 1 Step -1
        temp = olNameSPace.Folders(i).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(i)
            archStoreID = temp
        End If
    Next
    olNameSPace.AddStore newarchFileName
    For i = olNameSPace.Folders.Count To 1 Step -1
        temp = olNameSPace.Folders(i).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(i)
            newarchStoreID = temp
        End If
    Next

    Debug.Print vbTab & archive
    Debug.Print vbTab & newarchive

    createFolders archive, newarchive, startDate, endDate

    Debug.Print "Closing .pst files"

    olNameSPace.RemoveStore archive
    olNameSPace.RemoveStore newarchive
    Set olNameSPace = Nothing
    Set olApp = Nothing
    Set fs = Nothing
    MsgBox "SUGGESTION: open up the old archive in Outlook and compact it " & vbCrLf _
          & "to reclaim the lost space", vbInformation + vbOKOnly, "PSTSplitter"
    End
End Sub


Sub createFolders(objArchive, objNewArchive, sDate, eDate)
     Dim objSubFolders, objSubFolder, j, objNewFolder
     On Error Resume Next
     For j = objArchive.Items.Count To 1 Step -1
          'Debug.Print "Date Check: " & FormatDateTime(objArchive.Items.Item(j).CreationTime,2) & " " & sDate & " " & eDate & " " & objArchive.Items.Item(j).Class
          If (CDate(FormatDateTime(objArchive.Items.Item(j).CreationTime, 2)) >= CDate(sDate)) And (CDate(FormatDateTime(objArchive.Items.Item(j).CreationTime, 2)) <= CDate(eDate)) And (objArchive.Items.Item(j).Class = mailItemClass) Then
               Debug.Print "Moving: " & objArchive.Items.Item(j).Subject
               objArchive.Items.Item(j).Move objNewArchive
               If Err.Number <> 0 Then
                 Debug.Print "Error #" & Err.Number & " - " & Err.Description
            End If
          End If
     Next
     Set objSubFolders = objArchive.Folders
    If objSubFolders.Count = 0 Then
         ' === Stop condition reached
        Exit Sub
    End If
     For Each objSubFolder In objSubFolders
          Debug.Print "Processing SubFolder: " & objSubFolder.Name
          Set objNewFolder = OpenMAPIFolder("\" & objNewArchive.Name & "\" & objSubFolder.Name)
        If Not TypeName(objNewFolder) = "MAPIFolder" Then
            Set objNewFolder = objNewArchive.Folders.Add(objSubFolder.Name)
        End If
          createFolders objSubFolder, objNewFolder, sDate, eDate
    Next
    On Error GoTo 0
    Set objNewFolder = Nothing
    Set objSubFolder = Nothing
    Set objSubFolders = Nothing
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
     Set regEx = CreateObject("VBScript_RegExp_10.RegExp")
     regEx.Pattern = oldstr
     regEx.IgnoreCase = True
     regEx.Global = True
     ReplaceText = regEx.Replace(str1, newstr)
End Function

'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
    Else
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
    Set app = Nothing
End Function

Function IsNothing(Obj)
  If TypeName(Obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function