-
Auto Create and Sort to PST
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.
[vba]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[/vba]
Thanks
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules