[help] Attachment-stripper app/rule fails

[Patrick Pirtle]

I've re-invented the same ol' wheel--a vba to strip all
attachments from my incoming emails. My little app
looks at the categories assigned to my contacts, and
segregates the saved attachments into certain folders.
I use a rule to launch my app.

I have two problems that I've been trying to solve:

1. If I'm reading a newsgroup, and forward a post
to myself, ON OCCASION I get the "Rules in Error,"
"The Operation Failed" message, and the forwarded
message stays in the inbox. However, if I then run the
rule from the Rules Wizard, it works just fine on ALL
of the messages in the inbox.

2. When it fails, it deselects my rule, and I find myself
frequently having to turn the rule back on.

I'd REALLY like to solve problem #1. If I can't, I'd
like to figure out how to programmatically turn the rule
back on. Then, I could either have a button to do that,
piggyback the "re-select rule" code onto another rule,
or add a timer app, or...?

TIA for any help and suggestions.
--------------------------------------------------------
The impossible just takes a little longer




===== Code. Ignore if you're tired of reading =====

Public Sub MoveEmailAttachments(MyEmail As MailItem)
Dim oContact As ContactItem

Dim folder2Save2 As Outlook.MAPIFolder

Dim aCounter As Integer
Dim i As Integer
Dim x As Integer

Dim allContacts As Items

Dim oNS As NameSpace

Dim oSafeMail As Redemption.SafeMailItem

Dim folder2Use As String
Dim strAddress As String
Dim strCategories As String
Dim strFind As String

Set fs = CreateObject("Scripting.FileSystemObject")

Set oSafeMail = CreateObject("Redemption.SafeMailItem")
oSafeMail.Item = MyEmail

'Change body format from HTML to plain text
Select Case oSafeMail.BodyFormat
Case olFormatHTML, olFormatUnspecified
oSafeMail.BodyFormat = olFormatPlain
oSafeMail.Save
Case Else
End Select


Set oNS = Application.GetNamespace("MAPI")
Set allContacts = oNS.GetDefaultFolder(olFolderContacts).Items
strAddress = oSafeMail.Sender.Address

'Decide which category applies
For i = 1 To 3
strFind = "[Email" & i & "Address] = """ & strAddress & """ and [FileAs] <> ""Group"""
Set oContact = allContacts.Find(strFind)
If Not oContact Is Nothing Then 'The sender is in my Contacts
Select Case oContact.FileAs
Case "teamV8", "Engineers", "Cadd and Civil CADD Operators", "Company Wide Distribution", "Graphic
Standards Committee", _
"IS Department", "Project Managers", "Underground, Hawaiian Shirt" 'These are the display names for
group postings.
folder2Use = "Other"
Case Else

strCategories = oContact.Categories

If InStr(1, strCategories, "GSC", vbTextCompare) > 0 Then
folder2Use = "GSC"
End If

If folder2Use = "" And InStr(1, strCategories, "Engineers", vbTextCompare) > 0 Then
folder2Use = "Engineers"
End If

If folder2Use = "" And InStr(1, strCategories, "Principals", vbTextCompare) > 0 Then
folder2Use = "Principals"
End If

If folder2Use = "" And InStr(1, strCategories, "Other MKA Employees", vbTextCompare) > 0 Then
folder2Use = "Other MKA Employees"
End If

If folder2Use = "" And InStr(1, strCategories, "IS Dept", vbTextCompare) > 0 Then
folder2Use = "IS Dept"
End If

If folder2Use = "" And InStr(1, strCategories, "CADD DEPARTMENT", vbTextCompare) > 0 Then
folder2Use = "CADD DEPARTMENT"
End If
End Select

Exit For
End If
Next i

If folder2Use = "" Then folder2Use = "Other" 'ADDED 27SEP2005 TO FORCE UNKNOWS SENDERS' ATTACHMENTS
INTO THE 'OTHER' FOLDER

'Move attachments
If oSafeMail.attachments.Count Then
Set attachments = oSafeMail.attachments
For aCounter = 1 To oSafeMail.attachments.Count
Set attachment = oSafeMail.attachments.Item(1)
'If output folder doesn't exist, then create it
If fs.folderexists("c:\Documents and Settings\pap\My Documents\attachments\" & folder2Use) = False Then
fs.createfolder ("c:\Documents and Settings\pap\My Documents\Attachments\" & folder2Use)
End If

If fs.folderexists("c:\Documents and Settings\pap\My Documents\attachments\" & folder2Use & "\" &
oSafeMail.SenderName) = False Then
fs.createfolder ("c:\Documents and Settings\pap\My Documents\Attachments\" & folder2Use & "\" &
oSafeMail.SenderName)
End If

'Format the SaveAs filename
attachment.SaveAsFile ("c:\Documents and Settings\pap\My Documents\Attachments\" & folder2Use & "\" &
Trim(oSafeMail.SenderName) & "\" & attachment.FileName)

'Add text to the email body
oSafeMail.Body = oSafeMail.Body + vbCrLf + "Pirtle AttachmentMover
===============================================" _
+ vbCrLf + "Attachment moved to:" + vbCrLf + "<\\w7\attachments\" & folder2Use & "\" &
oSafeMail.SenderName & "\" & attachment.FileName & ">" _
+ vbCrLf + "----------------------------------------------------------------------" + vbCrLf

oSafeMail.attachments.Remove (1)
oSafeMail.Save
Next 'attachment

'Add an empty txt file as an attachment in order to preserve the paperclip icon. Modify it's
'hidden property to make it invisible to the Outlook UI
oSafeMail.attachments.Add ("c:\Documents and Settings\pap\My Documents\attachments\Attachment.Link")
oSafeMail.attachments.Item(1).Fields(&H7FFE000A) = True
oSafeMail.Save
End If

'Move email to correct inbox subfolder
Select Case folder2Use
Case "GSC"
Select Case strAddress
Case "(e-mail address removed)"
Case Else
oSafeMail.Move Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(folder2Use)
End Select
Case "Engineers", "Principals", "Other MKA Employees", "IS Dept", "CADD DEPARTMENT"
oSafeMail.Move Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(folder2Use)
Case Else
End Select

Set attachments = Nothing
Set attachment = Nothing
Set fs = Nothing
Set oNS = Nothing
Set allContacts = Nothing
Set oSafeMail = Nothing
Set oContact = Nothing
End Sub