'The following Outlook macros work together to eliminate common subject
'modifications that Google Groups makes to mail submitted to lists.  As this
'code progresses it's eliminating all sorts of subject adjustments made by
'anti-spam processors, not just Google.
'  It look like this project will deserve its own web page soon.
'  If you like this code, please let me know. Thanks.

'  2005jun20 : If you'd like to be put on a list to receive a brief note
'  when updates are made, please e-mail to outlookmacro@nebula-rnd.com.
'  When the list server is ready I'll send you an invitation.
'
'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.
' 2005jun16 TG : The recent FixSpecific code helps even more with sorting.
'
'Updates:
'   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.
'   2005may26 TG Allow for "[ SPAM 1 ] through "[ SPAM 20 ]"
'       Can someone tell me where this comes from?
'   NOTE1: Function names will be changed in the next version of these macros.
'       Simple directions for changes required will be in the Update notes below.
'   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 in 2006.
'   2005jun16 TG : I've added an extra call from NRnDCheckSubjects to
'	NRnDFixSpecific 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.  Please download updates periodically
'	to eliminate recent thread damage, the updates will not include changes for
'	threads that are no longer current.
'   2005jun16 TG : Remove trailing spaces, just in case...
'	2005jun20 TG : Remove redundant spaces first
'		Also remove new "Memo:" appended to responses in U2 forum
'   2005jun27 TG : Remove "{Spam?}" text
'
'
'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 macro.  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()".
'- Select and delete all code for that sub, "Function CheckGoogleSubject"
'    and/or "Function NRnDChangeSubject", whichever are present.
'- Insert all of 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.
'- You can now select one or more mail items and click your toolbar icon
'    as before.
'
'To setup a toolbar to execute the macros:
'- Right click in the empty blue space at the end of your toolbar.
'- Select Customize.
'- Select the Commands tab in the new Customize dialog.
'- Under Categories, find and click Macros.
'- Under Commands, find "Project1.RemoveGoogleSubjects".
'- 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 Google-modified subject.
'- Click the new icon.
'- Feel free to use ctrl-A to select all mail, then click the icon.
'
'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 RemoveGoogleSubjects()
' 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
        txt = myItem.subject
        changed = NRnDCheckSubjects(txt)
        If changed Then
            myItem.subject = txt
            myItem.Save
            If Err.Number <> 0 Then
                eTitle = "Error during item save"
                GoTo HandleError
            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
    If NRnDCheckFixSubject(txt, "  ", " ") Then NRnDCheckSubjects = True ' double spaces
    If NRnDCheckFixSubject(txt, _
         " - Email has different SMTP TO: and MIME TO:" & _
         " fields in the email addresses", "") Then NRnDCheckSubjects = True
     If NRnDCheckFixSubject(txt, "[*SPAM*] - ", "") Then NRnDCheckSubjects = True
     For idx = 1 To 20
        If NRnDCheckFixSubject(txt, "[ SPAM " & idx & " ]", "") Then NRnDCheckSubjects = True
     Next idx
     If NRnDCheckFixSubject(txt, "Memo: Re: ", "Re: ") Then NRnDCheckSubjects = True
     If NRnDCheckFixSubject(txt, "**SPAM: RE: ", "") Then NRnDCheckSubjects = True
     If NRnDCheckFixSubject(txt, "**SPAM: ", "") Then NRnDCheckSubjects = True
     If NRnDCheckFixSubject(txt, "SPAM-LOW: RE: ", "") Then NRnDCheckSubjects = True
     If NRnDCheckFixSubject(txt, "SPAM-LOW: ", "") Then NRnDCheckSubjects = True
     If NRnDCheckFixSubject(txt, "RE:  RE: ", "RE: ") Then NRnDCheckSubjects = True
     If NRnDCheckFixSubject(txt, "RE: RE: ", "RE: ") Then NRnDCheckSubjects = True
     If NRnDCheckFixSubject(txt, "RE: RE ", "RE: ") Then NRnDCheckSubjects = True
     If NRnDCheckFixSubject(txt, "  ", " ") Then NRnDCheckSubjects = True ' double spaces
     If NRnDFixSpecific(txt) Then NRnDCheckSubjects = True
     ' 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 NRnDFixSpecific(ByRef txt As String) As Boolean
    ' U2 Forum 200506016
    If NRnDCheckFixSubject(txt, "COMMIT/RO...", "COMMIT/ROLLBACK") Then NRnDFixSpecific = True
    If NRnDCheckFixSubject(txt, "COMMIT/R...", "COMMIT/ROLLBACK") Then NRnDFixSpecific = True
    ' U2 Forum 200506016
    If NRnDCheckFixSubject(txt, "N ew Z", "New Z") Then NRnDFixSpecific = True
    ' U2 Forum 200506016
    If NRnDCheckFixSubject(txt, "Zealan d", "Zealand") Then NRnDFixSpecific = True
    ' U2 Forum 200506016 (permanent)
    If NRnDCheckFixSubject(txt, "{unclassified}", "") Then NRnDFixSpecific = True
    If NRnDCheckFixSubject(txt, "{unclass ified}", "") Then NRnDFixSpecific = True
End Function

Function NRnDCheckFixSubject( _
    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
    NRnDCheckFixSubject = False
    Do
        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)
        NRnDCheckFixSubject = True
    End If
    Loop While pos > 0
End Function