Option Explicit
' Name:     StripRe Subject
' Purpose:  Strips RE: from subjects in the UKHA_D folder, to provide better sorting in group mode
' Author:   Robert R. Chasmer (C) Kaos Productions 2004
' Changes:  15/06/2004 by RRC,  Intitial version based on http://hurring.com/code/vb/outlook/vb_macro_script.txt &
'                               http://www.tek-tips.com/gviewthread.cfm/lev2/3/lev3/18/pid/68/qid/756530
'  v0.01    06/08/2004 by RRC,  Rather than a single replaces now checks an array of search strings for removal
'  v0.02    01/06/2005 by RRC,  Added code to process another list called Net Audio
'  v0.03    30/06/2005 by RRC,  Fixed the signing tool and created notes here to describe how.
'  v0.04    21/07/2005 by RRC,  Added a Fw: check to the string replaces.
' ------------------------------------------------------------------------------------------------------------
' Notes:    This macro was signed using Microsoft Office\Office\SELFCERT.EXE
'           Then choosing Tools > Digital Signature
'
'           Sometimes SelfCert will error with: "Could not create a certificate" or
'           "There was a problem with the digital certificate. The VBA project could not be signed.
'               The signature will be discarded."
'           Here's the way, I fixed it on my machine: MS XP SR1, Office 2000 SR1 and IE 6.0.2800.1106.xpsp2
'           1) Open a command box ([win] + R cmd)
'           2) cd \Program Files\Microsoft Office\Office (or the location of makecert.exe)
'           3) makecert -n "CN=Robert Chasmer" -sk MyNewRootKey -r -ss myNewRoot
'              (I found this in a newsgroup and I have no knowledge about these switches and parameters!)
'              reply: Succeeded
'           4) Find the location, where the new signature has been created ([win] + F; c:\,  by date descending)
'              one of the most top entries. (On my PC C:\Documents and Settings\chasmer\Application Data\Microsoft\Crypto\RSA\)
'           5) Zip up the contents of this folder as a backup then delete all old signatures in this folder.
'           6) Zip up the contents of C:\Documents and Settings\chasmer\Application Data\Microsoft\SystemCertificates\My\Certificates
'              Then delete all old signatures in all folders under, keeping the folders.
'           7) Create a new signature with selfcert.exe, which should now work.
'           8) Finally extract the zip file backups just incase there needed, NOT replacing any existing files.
' ------------------------------------------------------------------------------------------------------------

Dim arrReplace(4)


' Handle new mail here.  Its best not to have this running on your main inbox for performance reasons.
' Instead create a holding folder, then use a normal Outlook rule to move messages into it.
' This script will then fire and move the messages to your final target folder.
' e.g. INBOX --> (via rule) to LISTS --> (via script) to UKHA
Private Sub Application_NewMail()
    arrReplace(0) = "Re: "
    arrReplace(1) = "Fw: "
    arrReplace(2) = "Re[2]: "
    arrReplace(3) = "Re[4]: "
    arrReplace(4) = "Re[10]: "
    ' MsgBox ("NewMail")
    Call StripReSubject
End Sub


Public Sub StripReSubject()
    Dim oOutlook As Outlook.Application
    Dim oNameSpace As Outlook.NameSpace
    Dim oScanFolder As Outlook.MAPIFolder
    Dim oDestFolderUKHA As Outlook.MAPIFolder
    Dim oDestFolderNA As Outlook.MAPIFolder
    Dim oItems As Outlook.Items
    Dim oItem As Outlook.MailItem
    
    Dim strSubject As String
    Dim strSearch As Variant
    Dim intChanged As Integer
    Dim intUnchanged As Integer
    Dim boolChanged As Boolean
    
    ' Get to the current session of Outlook
    Set oOutlook = CreateObject("Outlook.Application")
    Set oNameSpace = oOutlook.GetNamespace("MAPI")
    
    ' Get a reference to the relevant mail folder
    Set oScanFolder = oNameSpace.GetDefaultFolder(olFolderInbox).Folders("Lists")
    Set oDestFolderUKHA = oNameSpace.GetDefaultFolder(olFolderInbox).Folders("Lists").Folders("Home Auto")
    Set oDestFolderNA = oNameSpace.GetDefaultFolder(olFolderInbox).Folders("Lists").Folders("Audiotron")
    
    ' Loop through a collection of mail items working on unread messages with [ukha_d] in the subject
    Set oItems = oScanFolder.Items
    intChanged = 0
    intUnchanged = 0
    For Each oItem In oItems
        boolChanged = False
        ' Only work on unread messages
        If oItem.UnRead = True Then
            strSubject = oItem.Subject
            ' Only work on UKHA_D messages
            If InStr(1, strSubject, "[ukha_d]", vbTextCompare) Then
                ' Strip Re: (and others) from subjects, to improve grouping
                For Each strSearch In arrReplace
                    If InStr(1, strSubject, strSearch, vbTextCompare) Then
                        boolChanged = True
                        oItem.Subject = Replace(oItem.Subject, strSearch, "", 1, -1, vbTextCompare)
                        'MsgBox ("Before:'" & strSubject & "', After:'" & oItem.Subject & "'")
                        oItem.Save
                        Exit For
                    End If
                Next
                
                ' Finally move the item from the Lists folder
                oItem.Move oDestFolderUKHA
            ElseIf InStr(1, strSubject, "[NA]", vbTextCompare) Then
                ' Strip Re: (and others) from subjects, to improve grouping
                For Each strSearch In arrReplace
                    If InStr(1, strSubject, strSearch, vbTextCompare) Then
                        boolChanged = True
                        oItem.Subject = Replace(oItem.Subject, strSearch, "", 1, -1, vbTextCompare)
                        'MsgBox ("Before:'" & strSubject & "', After:'" & oItem.Subject & "'")
                        oItem.Save
                        Exit For
                    End If
                Next
                
                ' Finally move the item from the Lists folder
                oItem.Move oDestFolderNA
            End If
        End If
        If boolChanged Then intChanged = intChanged + 1 Else intUnchanged = intUnchanged + 1
    Next
    
    'MsgBox ("Unchanged: " & intUnchanged & " messages, Changed: " & intChanged & " messages")
    Set oItem = Nothing
    Set oItems = Nothing
    Set oScanFolder = Nothing
    Set oNameSpace = Nothing
    Set oOutlook = Nothing
End Sub