Outlook 2000 VBA Macro Advice

[Tommy Noble]

I have a public folder which is totally bogged down with over 100,000
messages in it, due to several developers using the folder for automated
event logging on other systems. Their apps send a timestamp message via
smtp to this folder, and nobody had been housekeeping it. I don't want to
wipe it out, but I do want to make its contents manageable now, and going
forward.

Digging through Sue Mosher's articles, I figured most of what I need to do
out, and wrote the below macro. I'm looking for a few things here:

1) This works fine, often moving hundreds or thousands of messages - until
it stops with one or another mysterious error - one having to do with a bad
value returned for the Received Date, or the other, telling me it's unable
to move the message. When I restart it, the message which I thought was the
problem (the last message in the folder) does not halt the macro. What
could be causing this; how could I stop this from happening? Is it a
problem in my code or am I just bogging down my server?

2) Any suggestions for improvements/streamlining?

2a) I would like, for instance, to put a status window up, displaying the
number of messages processed/to-go, and a Cancel button (otherwise Outlook
appears to be unresponsive while it's working on this), and maybe showing
the subject line for each message as it's processed. Is there a way to do
this without slowing processing time substantially?

TIA, and THANKS to Sue Mosher for the volume of useful stuff on slipstick
and in her articles...

Tommy Noble

Sub CleanupThatFolder()
Dim strDataFolder As String
Dim strTargetFolder As String
Dim objTheFolder As MAPIFolder
Dim objTheTargetFolder As MAPIFolder
Dim colItems As Items
Dim objItem As Object
Dim strRcdTime As String
Dim strYear As String
Dim strMonth As String
Dim strYearMonth As String
Dim arrTime
Dim strLastFolder As String

strDataFolder = "Public Folders\All Public Folders\System
Logs\AllEvents"

Set objTheFolder = GetMAPIFolder(strDataFolder)
If Not objTheFolder Is Nothing Then
Set colItems = objTheFolder.Items
Set objItem = colItems.GetLast
strLastFolder = ""

Do Until objItem Is Nothing
strRcdTime = objItem.ReceivedTime
wrk = Split(strRcdTime, " ") ' split delimited by space
arrTime = Split(wrk(0), "/") ' split delimited by "/"
strYear = arrTime(2)
strMonth = arrTime(0)

' just one month's worth for now...
If strYear <> "2002" And strMonth <> "7" Then Exit Do

strYearMonth = strYear & "-" & strMonth
strTargetFolder = strDataFolder & "\" & strYearMonth
If strLastFolder <> strTargetFolder Then
Set objTheTargetFolder = GetMAPIFolder(strTargetFolder)
If objTheTargetFolder Is Nothing Then
objTheFolder.Folders.Add (strYearMonth) ' create the
target folder
End If
End If

' now move the message to the target folder
objItem.Move objTheTargetFolder

' and get the next objItem
Set objItem = colItems.GetLast

' one at a time for testing
' Set objItem = Nothing
Loop

Else
MsgBox ("No Folder!")
End If

End Sub

Function GetMAPIFolder(strName)
Dim objFolder As MAPIFolder

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")

arrName = Split(strName, "\")
Set objFolders = objNS.Folders
blnFound = False
For I = 0 To UBound(arrName)
For Each objFolder In objFolders
If objFolder.Name = arrName(I) Then
Set objFolders = objFolder.Folders
blnFound = True
Exit For
Else
blnFound = False
End If
Next
If blnFound = False Then
Exit For
End If
Next
If blnFound = True Then
Set GetMAPIFolder = objFolder
Else
Set GetMAPIFolder = Nothing
End If

Set objApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objFolders = Nothing
Set objExpl = Nothing
End Function

 

[Ken Slovak - [MVP - Outlook]]

The Outlook object model has memory leaks when iterating large
collections in a loop. I use CDO code when large collections are
involved and it's an order of magnitude faster anyway. However you can
break your code into calls to handle say 500 or 1000 items at a time.