'The following Outlook macros work together to eliminate common subject
'modifications that email middleware makes to mail submitted to lists.  As this
'code progresses it's eliminating all sorts of subject adjustments made by
'anti-spam processors, Google, and other people's mail clients.
'This project may deserve its own web page soon.
'If you like this code, please let me know. Thanks.

'How do I use it?
'After installing per the directions below, whenever you're looking at one or
'more mail items that have a funky subject, just click a toolbar button to
'clean it up.

'Why use this?:
'It 's easier to follow threads without seeing the word "**SPAM**" and other
'non-subject text in the subjects.  It's easier to sort the mail by subject.

'How can I be sure it works OK?
'Create a new backup folder.  Copy in mail items that you'd like to test, or all
'mail from one of your mail list folders.  Now go to that folder, select one or
'more mail items, run the macro and see if it does what you want. When you are
'sure that subjects are modified in an acceptable manner, delete the backup and
'start using the macro on your normal mail folders.

'This code only changes the Subject, not the "ConversationTopic" or
'ConversationIndex which are used by Outlook for some sorting tasks. I can write
'code to modify these too but unfortunately not as freeware.

' Please contact Nebula R&D for custom development which integrates MV DBMS
' business applications with Outlook.

'Updates:
'   20060225 TG : Re-sorted these updates with most recent at top.
'   20060225 TG : Updated install/update instructions and comments, added
'   more comments throughout.
'   20060224 TG : Completely avoid change if all changes result in null subject.
'   20060224 TG : Lots of changes made to clean up U2 forum subjects
'       *** You may not agree with Tony's preferences ***
'       Examples include changing "[U2][UD]" to just "[UD]", etc.
'   2005jun16 TG : I've added an extra call from NRnDCheckSubjects to
'   NRnDCheckTempSubjects which fixes very specific damage to subjects which has been
'   done by other people's mail clients.  Much of this code will be obsolete
'   after a specific thread is expired but if you have a lot of history this
'   will help to clean up the old junk.
'   Please download updates periodically to eliminate recent thread damage.
'   2005jun16 TG : Remove trailing spaces, just in case...
'   2005jun16 TG : The recent FixSpecific code helps even more with sorting.
'   2005may26 TG Allow for "[ SPAM 1 ] through "[ SPAM 20 ]"
'       Can someone tell me where this comes from?
'   2005may10 TG Remove another Googlemod
'       Remove "RE: RE: " prefixes (Good anytime, not just for Google)
'       Loop to remove multiple occurrences.
'       Above changes removed function CheckGoogleSubject and
'       replaced it with NRnDChangeSubject and a new calling signature.

'   NOTE1: Function names have been changed from earlier versions.
'       Unless you've added custom mods I suggest you just replace the old
'       macros with what's here.
'   NOTE2: An attempt was made to execute these functions from Outlook Rules.
'       Due to known issues in Rule/Script interaction, the code did not function as
'       expected and the effort was abandoned.  Expert advice given to me by an
'       Outlook MVP was to re-write all rules as VBA rather than combining rules
'       and scripts.  That won't happen.  I'll try again with Outlook 12 and if
'       Rule maintenance there is as bad as it is in prior versions then I will
'       write my own rule engine as an Outlook add-in.

'To install:
'- Use Alt+F11 to open the macro editor.
'- If you don't see any Modules in the tree in the left pane:
'   - Right click on Modules, Insert, Module.
'   - In the properties window, you may want to change the
'        Name to something like "Macros".
'- When you have a module, paste the code below anywhere in the module.
'- Click the toolbar Save icon (blue disk).
'- Close the window with the x in the corner or go to Menu>File>Close.
'
'To update an existing macro (completely remove replace old code):
'- Use Alt+F11 to open the macro editor.
'- Find the Module in the left-hand project tree that contains the
'   original macros.  You may need to double-click on modules to
'   see their code and use the "Declarations" listbox to find the
'   original code.
'- Scroll down to "Sub RemoveGoogleSubjects()" or use ctrl-F and search
'   for "nrnd" if you have a more recent version of these macros.
'- Select and delete all code and comments for that sub,
'   "Function CheckGoogleSubject"
'   and/or "Function NRnDChangeSubject", and any other NRnD macros.
'- Insert all of these comments and the code below.
'- Click the toolbar Save icon (blue disk).
'- Close the window with the x in the corner or go to Menu>File>Close.

' Because macro names have changed you will need to replace your
' toolbar button or simply change the Name of the macro it executes.

'To setup a toolbar to execute the macros:
'- Right click in the empty blue space at the end of your toolbar.
'- Select Customize.
'- If you already have a toolbar button setup:
'   - Right click the button and change the Name to "Project1.NRnDCleanSubjects"
'   - Skip down to the Close the Customize dialog step
'  If adding a new button...
'- Select the Commands tab in the new Customize dialog.
'- Under Categories, find and click Macros.
'- Under Commands, find "Project1.NRnDCleanSubjects".
'- Drag and drop the icon for that command to your toolbar.
'   - The location is your choice.
'   - You can re-drag that toolbar selection anywhere you want.
'- Right click that big toolbar button you just dropped.
'- Move down to Change Button Image, and select any icon.
'    - Changing and creating icons is easy and isn't discussed here.
'- Again, Right click the big toolbar button.
'- Select Default Style.  This leaves just the icon in the toolbar.
'- Close the Customize dialog with the Close button.

'To use the macros:
'- Select one or more mail items that have a messy subject.
'- Click the new icon.
'- Feel free to use ctrl-A to select all mail, then click the icon,
'   personally I do groups of 100 or so since I have a large archive.

'If someone has manually eliminated key text before replying to the
'group then mail may not all sort properly if they've not properly
'edited the text.  For example, if the subject is:
'    RE: [***SPAM] - real subject
'And they modify that down to:
'    RE: - real subject
'That will not sort in your subjects under "real subject" because they
'left the " -" in there.  Nothing can be done to automate this but
'subjects can certainly be revised programmatically if you really care,
'just look at this code, and be careful!

'If you find Google modifications that are not being removed:
'- Modify the macro.  Looking at it you'll see how.  It's easy.
'- OR - Check back at http://nebula-rnd.com/freeware for a more
'    recent version of this google_macro1.txt file
'- OR - Email Tony Gravagno and suggest a change.

'If you make changes or have comments, please contact Tony Gravagno.
'   TG @
'   Nebula-Rnd.com

'======== EVERYTHING BELOW THIS LINE IS CODE =========


Sub NRnDCleanSubjects()
' Written by Tony Gravagno : http://Nebula-RnD.com
' These macros are freeware provided by Nebula R&D.
' No warranty is stated or implied.
' Use at your own discretion and risk.
    Dim myItem As Outlook.MailItem
    Dim myOlSel As Outlook.Selection
    Dim changed As Boolean
    Dim txt As String
    Dim eTitle As String
    On Error GoTo 0
    Set myOlSel = Outlook.Application.ActiveExplorer.Selection
    For Each myItem In myOlSel ' loop through each mail item
        txt = myItem.subject
        changed = NRnDCheckSubjects(txt) ' sets a flag, do we need to save changes?
        If changed Then
            ' don't file empty subject
            If txt <> "" Then
                myItem.subject = txt
                myItem.Save
                If Err.Number <> 0 Then ' FWIW, errors have never occurred here
                    eTitle = "Error during item save"
                    GoTo HandleError
                End If
            End If
        End If
    Next
    GoTo AllDone
HandleError:
    MsgBox Err.Number & " " & Err.Description, _
        vbOKOnly, eTitle
AllDone:
    Set myItem = Nothing
    Set myOlSel = Nothing
End Sub

Function NRnDCheckSubjects(ByRef txt As String) As Boolean
' Written by Tony Gravagno : http://Nebula-RnD.com
' These macros are freeware provided by Nebula R&D.
' No warranty is stated or implied.
' Use at your own discretion and risk.
    Dim idx As Byte
    ' specific to U2 forum (Tony's preferences!!)
    If NRnDChangeSubject(txt, "[U2][U2]", "[U2]") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "[U2] [U2]", "[U2]") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "[U2] RE: [U2]", "[U2] RE: ") Then NRnDCheckSubjects = True
    ' we know we're in the U2 forum so if we see a UD or UV, remove the U2 part
    If NRnDChangeSubject(txt, "[U2] RE: [UV]", "[UV] RE: ") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "[U2] RE: [UD]", "[UD] RE: ") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "[U2][UD]", "[UD]") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "[U2][UV]", "[UV]") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "[U2] [UD]", "[UD]") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "[U2] [UV]", "[UV]") Then NRnDCheckSubjects = True
    
    If NRnDChangeSubject(txt, "RE: [U2] RE:", "RE: [U2] ") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "RE: [UV] RE:", "RE: [UV] ") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "RE: [UD] RE:", "RE: [UD] ") Then NRnDCheckSubjects = True
    
    ' special for military installations  ;)
    If NRnDChangeSubject(txt, "{unclassified}", "") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "Unclassified RE ", " RE ") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "Unclassified RE:", " RE:") Then NRnDCheckSubjects = True
    
    ' periodically good to remove extra spaces just to ensure good hits on other checks
    If NRnDChangeSubject(txt, "  ", " ") Then NRnDCheckSubjects = True ' double spaces
            
    ' check temporary subjects which have been messed up by people's typos,
    ' too long subject lines that are broken by some readers, etc.
    If NRnDCheckTempSubjects(txt) Then NRnDCheckSubjects = True
            
    ' these come from someone's spam filters
    If NRnDChangeSubject(txt, "[*SPAM*] - ", "") Then NRnDCheckSubjects = True
    For idx = 1 To 20
       If NRnDChangeSubject(txt, "[ SPAM " & idx & " ]", "") Then NRnDCheckSubjects = True
    Next idx
    If NRnDChangeSubject(txt, "Memo: Re: ", "Re: ") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "**SPAM: RE: ", "") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "**SPAM: ", "") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "{Spam?} ", "") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "SPAM-LOW: RE: ", "") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "SPAM-LOW: ", "") Then NRnDCheckSubjects = True
    
    ' periodically good to remove extra spaces just to ensure good hits on other checks
    If NRnDChangeSubject(txt, "  ", " ") Then NRnDCheckSubjects = True ' double spaces
    
    If NRnDChangeSubject(txt, "RE: RE[2]:", "RE:") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "RE[2]:", "RE:") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "RE: RE: ", "RE: ") Then NRnDCheckSubjects = True
    If NRnDChangeSubject(txt, "RE: RE ", "RE: ") Then NRnDCheckSubjects = True
    
    ' periodically good to remove extra spaces just to ensure good hits on other checks
    If NRnDChangeSubject(txt, "  ", " ") Then NRnDCheckSubjects = True ' double spaces
    
    ' remove trailing spaces, just in case...
    Do
       idx = 0 ' simple flag here
       If Right(txt, 1) = " " Then
           idx = 1
           txt = Mid(txt, 1, Len(txt) - 1)
           NRnDCheckSubjects = True
       End If
    Loop While idx > 0
End Function

Function NRnDCheckTempSubjects(ByRef txt As String) As Boolean
' Written by Tony Gravagno : http://Nebula-RnD.com
' These macros are freeware provided by Nebula R&D.
' No warranty is stated or implied.
' Use at your own discretion and risk.
    ' These are specific issues found in e-mail forums that Tony subscribes to.
    ' The issues come and go and have only been added here because they were
    ' a temporary nuissance.
    ' U2 Forum 200506016
    If NRnDChangeSubject(txt, "COMMIT/RO...", "COMMIT/ROLLBACK") Then NRnDCheckTempSubjects = True
    If NRnDChangeSubject(txt, "COMMIT/R...", "COMMIT/ROLLBACK") Then NRnDCheckTempSubjects = True
    ' U2 Forum 200506016
    If NRnDChangeSubject(txt, "N ew Z", "New Z") Then NRnDCheckTempSubjects = True
    ' U2 Forum 200506016
    If NRnDChangeSubject(txt, "Zealan d", "Zealand") Then NRnDCheckTempSubjects = True
    ' U2 Forum 200506016 (permanent)
    If NRnDChangeSubject(txt, "{unclass ified}", "") Then NRnDCheckTempSubjects = True
    ' U2 Forum 20060224
    ' no idea where this comes from (couple variations now I think)
    If NRnDChangeSubject(txt, _
        " - Email has different SMTP TO: and MIME TO:" & _
        " fields in the email addresses", "") Then NRnDCheckTempSubjects = True
    If NRnDChangeSubject(txt, _
        "Email has different SMTP TO: and MIME TO: " & _
        "fields in the email addresses -", "") Then NRnDCheckTempSubjects = True
    If NRnDChangeSubject(txt, "mc@nashbar.com - ", "") Then NRnDCheckTempSubjects = True
    ' don't remove mc@nashbar.com all by itself because people are using that as a subject
End Function

Function NRnDChangeSubject( _
    ByRef subject As String, sFrom As String, sTo As String) As Boolean
' Written by Tony Gravagno : http://Nebula-RnD.com
' These macros are freeware provided by Nebula R&D.
' No warranty is stated or implied.
' Use at your own discretion and risk.
    Dim pos As Integer
    Dim temp As String
    NRnDChangeSubject = False
    Do
        ' return column position for text that we're looking for
        pos = InStr(1, subject, sFrom, VbCompareMethod.vbTextCompare)
    If pos > 0 Then
        If pos > 1 Then temp = Left(subject, pos - 1) Else temp = ""
        subject = temp & sTo & Mid(subject, pos + Len(sFrom), 999)
        NRnDChangeSubject = True ' set the flag, we made a change !
    End If
    Loop While pos > 0
End Function