Auto Create and Sort to PST

[BlueTick]

I need to limit the size of my mailbox, so I have to create PST files on my hard drive. I have been just moving my mail to a PST, but this causes a problem of corruption to the file due to the size. So, I need to create many smaller PST files. I would like a macro that will do the following:

1) Look at an email address in my inbox and make a PST (if it dosent exist) with the email address as the name of the PST.
Example:

C:\Documents and Settings\"user name"\My Documents\"Sender"

2) Sort the email to that PST

3) Move to the next email, repeat

Anybody have a clue how to start? Also if possible sort the emails in the PST by folders based on date.

I believe this is an example by Sue Mosher, but I realy do not know what it does or how...I just know I cannot get it to work.

Function SetNewStore2(strFileName As String, strDisplayName As String) As Outlook.MAPIFolder
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim arr() As String
Dim i As Integer
On Error Resume Next

Set objOL = Application ' intrinsic Application object in Outlook VBA
Set objNS = objOL.GetNamespace("MAPI")

' build array of all the information store IDs
ReDim arr(objNS.Folders.Count - 1)
i = 0
For Each objFolder In objNS.Folders
arr(i) = objFolder.EntryID
i = i + 1
Next
Set objFolder = Nothing

objNS.AddStore strFileName
' make "best guess" that new store is the last one in the collection
Set objFolder = objNS.Folders.GetLast
' but confirm against array
If FolderEntryIDIsInArray(objFolder, arr()) Then
' check all top-level store folders against array
' until we find the one that doesn't have an
' EntryID in the array
For i = 1 To (objNS.Folders.Count - 1)
Set objFolder = objNS.Folders.GetPrevious
If Not FolderEntryIDIsInArray(objFolder, arr()) Then
Exit For
End If
Next
End If

' give the newly added PST store a display name
' This should be unique to make it easier to distinguish
' it from other stores.
objFolder.Name = strDisplayName

' these statements refresh the folder name
objNS.RemoveStore objFolder
Set objFolder = Nothing
objNS.AddStore strFileName

' repeat the earlier process to get the newly added store
' make "best guess" that new store is the last one in the collection
Set objFolder = objNS.Folders.GetLast
' but confirm against array
If FolderEntryIDIsInArray(objFolder, arr()) Then
' check all top-level store folders against array
' until we find the one that doesn't have an
' EntryID in the array
For i = 1 To (objNS.Folders.Count - 1)
Set objFolder = objNS.Folders.GetPrevious
If Not FolderEntryIDIsInArray(objFolder, arr()) Then
Exit For
End If
Next
End If

Set SetNewStore2 = objFolder

Set objOL = Nothing
Set objNS = Nothing
End Function

Function FolderEntryIDIsInArray(fld As Outlook.MAPIFolder, arr() As String) As Boolean
Dim blnInArray As Boolean
For i = 0 To UBound(arr)
If arr(i) = fld.EntryID Then
blnInArray = True
Exit For
End If
Next
FolderEntryIDIsInArray = blnInArray
End Function

Thanks :help