Archiving Email By Date

[Mark Ivey]

With help from Sue Mosher, Dev Ashish, & Steven Harvey... I was finally able
to finish the macro I have been needing at work to archive my email. The
code below is a variation that will archive email by date. I thought I would
post it here if anyone else was interested (or just wanted to proof my work
for mistakes). I am always open for improvements.

Mark Ivey
__________________________________________________________________________________
''' Dev Ashish's Function http://www.mvps.org/access/api/api0008.htm
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As
String, nSize As Long) As Long

''' Dev Ashish's Function http://www.mvps.org/access/api/api0008.htm
Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If (lngX > 0) Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = vbNullString
End If
End Function

''' Sue Mosher's Function
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

''' Sue Mosher's 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

''' Steven Harvey's Function ([email protected])
http://www.outlookcode.com/codedetail.aspx?id=827
Function FolderExist(sFileName As String) As Boolean
FolderExist = IIf(Dir(sFileName, vbDirectory) <> "", True, False)
End Function

''' Procedure made with help from Sue Mosher
Sub ArchiveEmailByDate()
On Error Resume Next
Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Dim myStore As String, objUserName As String, myPath As String
Dim myFolder As String, newStore As Outlook.MAPIFolder
Dim objStore As Outlook.MAPIFolder

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is
selected
MsgBox "Please select one or more emails before running this
utility!", _
vbOKOnly, "Email Archive Utility"
Exit Sub
End If

objUserName = fOSUserName

myStore = Format(Date, "yyyy")
myPath = "C:\Documents and Settings\" & objUserName & _
"\Local Settings\Application Data\Microsoft\Outlook\" & _
myStore & ".pst"

Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objStore = objNS.Folders(myStore)

For Each objItem In Application.ActiveExplorer.Selection

myFolder = Format(objItem.SentOn, "mm") & " " &
Format(objItem.SentOn, "mmmm")

If objStore Is Nothing Then
Set newStore = SetNewStore2(myPath, myStore)
Set objStore = objNS.Folders(myStore)
End If

Set objFolder = objNS.Folders(myStore)

If FolderExist(myFolder) = False Then
objFolder.Folders.Add (myFolder)
Set objFolder = objNS.Folders(myStore).Folders(myFolder)
End If

Set objFolder = objNS.Folders(myStore).Folders(myFolder)

If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move objFolder
Set objFolder = objNS.Folders(myStore)
End If
End If
Next
Set objNS = Nothing
Set objInbox = Nothing
Set objFolder = Nothing
Set newStore = Nothing
End Sub