Outlook subject fixer

gistfile1.vb

Private WithEvents oldFolder As Items
Private WithEvents newFolder As Items


Private Sub Application_Startup()
    Set oldFolder = Application.Session.DefaultStore.GetRootFolder.Folders("Âõîäÿùèå").Folders("Servicedesk").Folders("Íàçíà÷åííûå çàÿâêè").Items
    Set newFolder = Application.Session.DefaultStore.GetRootFolder.Folders("Âõîäÿùèå").Folders("Servicedesk").Folders("Íîâûé ServiceDesk").Items
    MsgBox "Startup"
    MsgBox oldFolder.Count
    MsgBox newFolder.Count
End Sub

Private Sub oldFolder_ItemAdd(ByVal item As Object)
    Old_FixSubject item
End Sub

Private Sub newFolder_ItemAdd(ByVal item As Object)
    New_FixSubject item
End Sub




Sub New_FixSubject(item As Outlook.MailItem)
    Dim verbose, number, desc  As String
    
    Tools.Log "New Before fix subject", item
    
    number = ExtractNumber(item, "IM\d+")
    desc = New_ExtractDescription(item)
    verbose = "[" & number & "] " & desc
    Debug.Print verbose
    item.UserProperties.Add("Verbose", olText).Value = verbose
    
    Tools.Log "After fix subject", item
    item.Save
    Tools.Log "After save", item, True
End Sub



Sub Old_FixSubject(item As Outlook.MailItem)
    Dim verbose, number, desc  As String
        
    Tools.Log "Old Before fix subject", item
    
    number = ExtractNumber(item, "\d+")
    desc = Old_ExtractDescription(item)
    verbose = "[" & number & "] " & desc
    Debug.Print verbose
    item.UserProperties.Add("Verbose", olText).Value = verbose
    
    Tools.Log "After fix subject", item
    item.Save
    Tools.Log "After save", item, True
End Sub

Private Function New_ExtractDescription(item As Outlook.MailItem)
    Dim p1, p2 As Long
    Dim body As String
    
    body = item.HTMLBody
    
    p1 = InStr(1, body, "Àííîòàöèÿ")
    If p1 = 0 Then GoTo Fail
    p1 = InStr(p1, body, "<font")
    If p1 = 0 Then GoTo Fail
    p1 = InStr(p1, body, ">")
    If p1 = 0 Then GoTo Fail
    p2 = InStr(p1, body, "</font>")
    Debug.Print p1, p2,
    
    New_ExtractDescription = Mid(body, p1 + 1, p2 - p1 - 1)
    GoTo EndOfFunction

Fail:
    New_ExtractDescription = "?????"

EndOfFunction:
End Function



Private Function Old_ExtractDescription(item As Outlook.MailItem) As String
    Dim regex As RegExp
    Dim match As MatchCollection
    Dim line As String
    Dim subj As String
    
    Set regex = CreateObject("vbscript.regexp")
    With regex
        .MultiLine = True
        .Global = True
        .IgnoreCase = True
        .Pattern = "Òåìà çàÿâêè:(.*)"
    End With
    Set match = regex.Execute(item.body)
    Let line = match.item(0)
    Let subj = Tools.TrimEOL(Split(line, ": ", 2)(1))
    
    Old_ExtractDescription = subj
End Function

Function ExtractNumber(item As Outlook.MailItem, mask As String)
    Dim rx As RegExp
    Dim match As MatchCollection
    
    Set rx = CreateObject("vbscript.regexp")
    rx.Pattern = mask
    Set match = rx.Execute(item.subject)
    If match.Count = 1 Then
        ExtractNumber = match.item(0)
    Else
        ExtractNumber = "???"
    End If

End Function


Sub new_test()
    Dim its As Items
    Dim item As Outlook.MailItem
    Set its = Application.Session.DefaultStore.GetRootFolder.Folders("Âõîäÿùèå").Folders("Servicedesk").Folders("Íîâûé ServiceDesk").Items
    Set item = its.GetLast()
    New_FixSubject item
End Sub

Sub old_test()
    Dim its As Items
    Dim item As Outlook.MailItem
    Set its = Application.Session.DefaultStore.GetRootFolder.Folders("Âõîäÿùèå").Folders("Servicedesk").Folders("Íàçíà÷åííûå çàÿâêè").Items
    Set item = its.GetLast()
    Old_FixSubject item
End Sub