I have written a macro, originally for in Outlook 2003, that seems to be
affected by our upgrade to Outlook 2007.
The macro searches the subject of all of the messages in the inbox for a
certain string (BCE #), and if it finds the string, it extracts a job number
following the string, and saves it to a matching job number folder on the
network. Some subjects contain multiple instances of the search string.
Some days, the macro works just fine, other days it only scans a few
messages, then says that it has completed successfully.
Any advice or suggestions on what to look for or change? I don't know VBA
and still wonder how I was able to piece this together.

Public Sub SaveProjects()

Dim Inbox As Outlook.MAPIFolder
Dim ns As NameSpace
Dim item As Object
Dim strCheck As String, i As Integer
Dim LogFile
Dim strdate As String
Dim sPath As String

strtoday = Date
strCheck = "\/:*?|"
For i = 1 To Len(strCheck)
strtoday = Replace(strtoday, Mid$(strCheck, i, 1), "-")
Next i

'This section creates the html file on the hard drive
'----------------------------------------------------
Open "c:\savedemail-" & strtoday & ".html" For Append As #1
Print #1, ""
Print #1, ""
Print #1, " bordercolor=#c0c0c0>"
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, "Archived Messages - "
& Now & ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, " size=1>Date"
Print #1, " size=1>Path"
Print #1, " size=1>File Name"
Print #1, ""
Close #1

'This section scans the messages in the Inbox for "BCE #" (case insensitive).
'If found, it extracts 5 characters after the # and sets them as the job
number.
'It then scans the network for the job number.
'-------------------------------------------------------------------------------
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
For Each item In Inbox.Items
If InStr(1, item.Subject, "BCE #", 1) > 0 Then
strtemp = Split(item.Subject, "BCE #", , 1)
For n = 0 To UBound(strtemp)
strtemp(n) = Left(strtemp(n), 5)
If IsNumeric(strtemp(n)) Then
strill = "\/:*?""|"
For i = 1 To Len(strill)
item.Subject = Replace(item.Subject, Mid$(strill, i, 1), "-")
Next i
strpar = ")."
For i = 1 To Len(strpar)
strtemp(n) = Replace(strtemp(n), Mid$(strpar, i, 1), "")
Next i
strzero = Mid$(strtemp(n), 1, 1)
If strzero = "0" Then
strtemp(n) = Right(strtemp(n), 2)
End If
strtemp(n) = Trim(strtemp(n))
job = Left(strtemp(n), Len(strtemp(n)) - 3)
sjob = "p:\" & Format(job, "00") & "000s\" & strtemp(n)
semail = sjob & "\email"

'This section saves the message if the job number is found.
'If the file exists, it adds a number to the end until it can be saved.
'This section also adds an entry into the html file for each message that is
saved.
'-----------------------------------------------------------------------
If Not item.FlagStatus = 2 Then
If DirExists(sjob) Then
If DirExists(semail) Then
If FileThere(sjob & "\email\" & item.Subject &
".msg") Then
n = 0
Do
If FileThere(sjob & "\email\" & item.Subject &
"-" & n & ".msg") Then
n = n + 1
Else
Exit Do
End If
Loop
Open "c:\savedemail-" & strtoday & ".html" For
Append As #1
Print #1, " size=1>" & Now & ""
Print #1, " size=1>"; sjob; ""
Print #1, " size=1>"; item.Subject; ""
Close #1
item.SaveAs sjob & "\email\" & item.Subject & "-" &
n & ".msg", olMSG
'item.Delete
Else
Open "c:\savedemail-" & strtoday & ".html" For
Append As #1
Print #1, " size=1>" & Now & ""
Print #1, " size=1>"; sjob; ""
Print #1, " size=1>"; item.Subject; ""
Close #1
item.SaveAs sjob & "\email\" & item.Subject &
".msg", olMSG
'item.Delete
End If
'If the job number is not found, the message is flagged with a green flag.
'If the email folder is not found, the message is flagged with an orange flag.
'-------------------------------------------------------------------------
Else
If item.FlagStatus = 2 Then
item.FlagIcon = 1 'olPurpleFlagIcon
item.Save
Else
item.FlagStatus = 2 'olFlagMarked
item.FlagIcon = 2 'olOrangeFlagIcon
item.Save
End If
End If
Else
If item.FlagStatus = 2 Then
item.FlagIcon = 1 'olPurpleFlagIcon
item.Save
Else
item.FlagStatus = 2 'olFlagMarked
item.FlagIcon = 3 'olGreenFlagIcon
item.Save
End If
End If
End If
End If
Next
If Not item.FlagStatus = 2 Then
item.Delete
End If
End If
Next
Open "c:\savedemail-" & strtoday & ".html" For Append As #1
Print #1, ""
Print #1, ""
Close #1
MsgBox "Done"
End Sub
Function DirExists(ByVal PathName As String) As Boolean
Dim iTemp As Integer
On Error Resume Next
iTemp = GetAttr(PathName)
Select Case Err.Number
Case Is = 0
DirExists = True
Case Else
DirExists = False
End Select
On Error GoTo 0
End Function
Function FileThere(FileName As String) As Boolean
FileThere = (Dir(FileName) > "")
End Function

Archived from group: microsoft>public>office>developer>outlook>vba