Option Explicit

Private WithEvents olInboxItems As Items

Private Sub Application_Startup()
    ' Inicialitzar objectes. S'executa automàticament en arrencar Outlook
    Dim objNS As NameSpace
    Set objNS = Application.GetNamespace("MAPI")
    ' Carpeta d'entrada
    Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
    Set objNS = Nothing
End Sub

Private Sub Application_Quit()
    ' disassociate global objects
    Set olInboxItems = Nothing
End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

    If TypeOf Item Is MailItem Then
        ' Canviar el subject del correu i gravar el missatge
        Item.Subject = convertirSubject(Item.Subject)
        Item.Save
    End If
End Sub

Private Function convertirSubject(ByVal subjectOriginal As String) As String
    ' Número de modificadors dels subjects. Són els elements que es buscaran al llarg
    ' de tot el subject i s'acumularan al principi, i sense repeticions
    Const maxModificadors = 3
    
    ' Array per contenir els modificadors
    Dim modificadors(1 To maxModificadors) As String
    ' Comptador
    Dim numModificador As Integer
    ' Nou subject
    Dim subjectNou As String
    
    ' Escrivim els modificadors. Apareixeran en el subject tal com els escrivim aquí
    modificadors(1) = "Re:"
    modificadors(2) = "Fwd:"
    modificadors(3) = "Réf:"
    
    ' Inicialització
    subjectNou = subjectOriginal
  
    ' Buscar cadascun d'aquests modificadors al subject i substituir-lo si és repetit
    For numModificador = 1 To maxModificadors
        convertirSubjectModificador subjectNou, modificadors(numModificador)
    Next

    ' Eliminar tots els espais redundants (més d'un espai seguit)
    trimTotal subjectNou
    
    ' Retornar el valor obtingut
    convertirSubject = subjectNou
End Function

Private Sub convertirSubjectModificador(linEnt As String, ByVal modificador As String)
    Dim hiHaModificador As Boolean       ' Indicador de si hi ha modificador
    Dim posModificador As Integer        ' Posició del modificador dins del subject
    Dim linEntMajuscules As String       ' Conversió a majúscules (comparació es en majúscules)
    Dim modificadorMajuscules As String  ' Modificador en majúscules (comparació es en majúscules)

    ' Inicialitzacions
    hiHaModificador = False
    modificadorMajuscules = UCase(modificador)
    linEntMajuscules = UCase(linEnt)
    
    ' Buscar i eliminar el modificador dins del subject, fins que no en quedi cap
    Do
        ' Localitzar el modificador (comparació en majúscules)
        posModificador = InStr(linEntMajuscules, modificadorMajuscules)
        ' Si hi és
        If posModificador <> 0 Then
            ' Anotar-ho
            hiHaModificador = True
            ' Treure el modificador del subject
            linEnt = Mid(linEnt, 1, posModificador - 1) + Mid(linEnt, posModificador + Len(modificador), Len(linEnt) - posModificador - Len(modificador) + 1)
            ' Convertir de nou a majúscules
            linEntMajuscules = UCase(linEnt)
        End If
    Loop Until posModificador = 0
    
    ' Si hem trobat el modificador
    If hiHaModificador Then
        ' Afegir-lo per davant, per mostrar-lo al subject final
        linEnt = modificador + " " + linEnt
    End If
End Sub

Private Sub trimTotal(s As String)
    ' Elimina tots els espais inicials i finals de S, i els interiors redundants
    ' Es consideren redundants 2 o més espais seguits

    Dim t As String
    Dim c As String
    Dim k As Integer
    Dim anteriorEsEspai As Boolean

    ' Eliminar espais anteriors i posteriors
    s = Trim(s)
    ' Inicialitzar
    t = ""                  ' Cadena final
    anteriorEsEspai = True  ' Senyalador

    ' Recórrer tota la cadena
    For k = 1 To Len(s)
        ' Extreure caràcter i-èssim
        c = Mid(s, k, 1)
        ' Comparar-lo amb l'espai
        If c <> " " Then
            ' No és espai, afegir el caràcter a la cadena final
            t = t + c
            ' Anotar que no és espai
            anteriorEsEspai = False
        Else
            ' És un espai; si l'anterior no ho era, afegir-lo
            If (Not anteriorEsEspai) Then t = t + c
            ' Recordar-se que aquest caràcter és espai
            anteriorEsEspai = True
        End If
    Next
    ' Retornar cadena final
    s = t
End Sub