OutlookMsgParser

VbaProject.OTM

Option Explicit
Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

  On Error GoTo ErrorHandler
  Dim Msg As Outlook.MailItem
  If TypeName(item) = "MailItem" Then
    Set Msg = item
    ' ******************
    ' do something here
    ' ******************
    
  End If
ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Private Sub Application_NewMail()
    'MsgBox "Íîâîå ïèñüìî "
    Call ZNO_ZMMDOC_CRE
End Sub

Public Sub ZNO_ZMMDOC_CRE()
    Dim DoW As String 'Äàòà íà÷àëà ðàáîò
    Dim lastrow As Long 'ïåðåìåííàÿ ïîèñêà ïîñëåäíåé ñòðîêè â Excel
    Dim myArray As Variant
    Dim i As Long
    
    Dim olItem As Outlook.MailItem 'ïåðåìåííàÿ, îïðåäåëÿþùàÿ ïèñüìî
    Dim sText As String 'ìàññèâ äàííûõ äëÿ ïîèñêà ñîîòâåòñòâèé ðåãåêñïîâ
    Dim Excel As Object
    Dim ExcelBook As Object
    
    Set ZNOnumber = CreateObject("VBScript.RegExp")
    ZNOnumber.Pattern = "(SR-[1-9]{7})"
    
    Set olItem = ActiveExplorer.Selection.item(1)
    
    sText = olItem.Body
    On Error Resume Next
    DoW = CStr(Year(Now))
    Set Excel = GetObject(, "Excel.Application")
    
    'MsgBox ZNOnumber.Test(TempStr)

    
    
    
    If Err.Number <> 0 Then
        If olItem.SenderName = "SDesk" Then
            myArray = Split(olItem.Body, Chr(13) & Chr(10))
            
            If UBound(myArray) > -1 Then
                lastrow = worksheet.Cells(worksheet.Rows.Count, 1).End(xlUp).Row + 1
                For i = 0 To UBound(myArray)
                    'MsgBox myArray(i)
                    If InStr(Left(myArray(i), 10), "Ïîëó÷àòåëü") > 0 Then
                        If InStr(myArray(i), "Иванов") Then
                            MsgBox "Íàø êëèåíò", vbApplicationModal, "ÇÍÎ"
                            'worksheet.Cells(i, 1).Value = myArray(i)
                        Else
                            Exit For
                        End If
                        
                    ElseIf InStr(Left(myArray(i), 7), "??????:") > 0 Then
                        'worksheet.Cells(lastrow, 2).Value = myArray(i)
                    ElseIf InStr(Left(myArray(i), 11), "????/?????:") > 0 Then
                        'worksheet.Cells(lastrow, 3).Value = myArray(i)
                    End If
                Next i
            End If
        End If
        
        If InStr(olItem.SenderName, "Êîðñàêîâ Àëåêñåé Ñåðãååâè÷") Then
            'MsgBox olItem.Body
        End If
        
        
        'MsgBox Err.Description
        'Set Excel = CreateObject("Excel.Application")
        'Set xlBook = Excel.Workbooks.Add
        'Set worksheet = Excel.Worksheets(1)
        'Excel.Visible = True
        
        
        
        
        'oBook.SaveAs ExcelBook
    Else
        
    End If
    On Error GoTo 0
    
    
End Sub

Simple filtring script for MS Outlook notifying user about message from somebody.