Создание правила VBA в Outlook

Option Explicit
 
Dim oNamespace As Outlook.NameSpace
Dim inbox As Outlook.MAPIFolder
Dim MyFol As Outlook.MAPIFolder
Dim MyFolS As Outlook.MAPIFolder
Dim MyFolSi As Outlook.MAPIFolder
Dim Item As Object
Dim STR() ' массив сотрудников с коэффмциентами
 
Sub РАСКИДАТЬ2(Item As Outlook.MailItem)
Dim i, NUM As Integer
Dim oOutlook As New Outlook.Application
Dim SOS()
Dim DEG
SOS = Array("досрочка", "погашення", "теме", "Планета", "Здравствуйте") ' сюда добавлять слова поиска
 
STR = Выбрать_список_сотрудников ' проверяем наличие. нет - создаём папки сотрудников
'obnul
NUM = Val(GetSetting("OUTL", "NASTR", "NUM")) 'считываем последний номер
 
If NUM = 0 Then 'если первый раз
    NUM = 1
End If
Do While NUM > 100 'пока счётчи больше 100
    NUM = NUM - 100 ' уменьшаем на 100
Loop
SaveSetting "OUTL", "NASTR", "NUM", NUM 'запоминаем
 
 
Set oNamespace = oOutlook.GetNamespace("MAPI")
Set inbox = oNamespace.Folders(1).Folders("Входящие")
 
'раскидываем по заголовка писем
    For Each Item In inbox.Items ' перебор всех писем в папке "Входящие"
        For i = 0 To UBound(SOS) '
            If InStr(1, Item, SOS(i)) > 0 Then
                NUM = NUM + 1
                DEG = Первый
Item.Move oNamespace.Folders(1).Folders("Сотрудники").Folders(STR(DEG, 0))
                STR(DEG, 2) = STR(DEG, 2) + 1 'увеличиваем счётчик
                SaveSetting "OUTL", "NASTR", STR(DEG, 0) & "_p", STR(DEG, 2) 'запоминаем
                Exit For
            End If
        Next i
    Next
        
'Для поиска в тексте сообщений необходимо сделать разрешение доступа максиум на 10 минут
'бесплатных прог. для этого нет
'1.вариант: перед запуском программы поставить галочку на 10 мин.
'2.вариант: вроде можно программно изменить ключ в реестре с помощью АПИ функции.
'Но тоже только на 10мин
'я даже находил модульс кодом. Достаточно много кода
'Поэтому пока только по заголовкам
'Если надо искать и в теле писем: разкомментировать блок. При запросе установить галку и 10 мин
'
'''''''''''''''''''''''''''''
''''''''''раскидываем по тексту писем
'    For Each Item In inbox.Items ' перебор всех писем в папке "Входящие"
'        For i = 0 To UBound(SOS) '
'            If InStr(1, Item.Body, SOS(i)) > 0 Then
'                NUM = NUM + 1
'                DEG = Первый
'Item.Move oNamespace.Folders(1).Folders("Сотрудники").Folders(STR(DEG, 0))
'                STR(DEG, 2) = STR(DEG, 2) + 1 'увеличиваем счётчик
'                SaveSetting "OUTL", "NASTR", STR(DEG, 0) & "_p", STR(DEG, 2) 'запоминаем
'                Exit For
'            End If
'        Next i
'    Next
 ''''''''''''''''''''''''
SaveSetting "OUTL", "NASTR", "NUM", NUM ' запоминаем последнее значение счётчика
MsgBox "OK", 64, ""
End Sub
 
Private Function Выбрать_список_сотрудников()
Dim i
Dim oOutlook As New Outlook.Application
    Dim oNamespace As Outlook.NameSpace
    Dim oChildFolder As Outlook.MAPIFolder
    Set oNamespace = oOutlook.GetNamespace("MAPI")
    
    If Not StartProc1("Сотрудники") Then
        Set oNamespace = oOutlook.GetNamespace("MAPI")
        Set MyFol = oNamespace.Folders(1)
        Set MyFolS = MyFol.Folders.Add("Сотрудники")
        MsgBox "Была создана отсутствующая папка " & """" & "Сотрудники" & """" & vbCrLf _
        & "Создайте в папке " & """" & "Сотрудники" & """" & "папки по фамилиям сотрудников", 64, ""
        Exit Function
    End If
    Выбрать_список_сотрудников = SOTR("Сотрудники")
 
End Function
 
Private Function Первый()
Dim i, MIN, MAX, T, P, K
MIN = 1E+31
MAX = 0
 
For i = 1 To UBound(STR)
    If STR(i, 2) = 0 Then
        T = STR(i, 1)
        If MAX < T Then MAX = T: P = i
    End If
Next
 
If MAX > 0 Then Первый = P: Exit Function
 
For i = 1 To UBound(STR)
    If STR(i, 2) > 0 Then
        If STR(i, 1) > 0 Then
            T = STR(i, 2) / STR(i, 1)
            If MIN > T Then MIN = T: K = i
        End If
    End If
Next
Первый = K
 
End Function
 
Private Function SOTR(FOLD)
Dim m(), ST, P, Nm, J, R()
Dim i
Dim oOutlook As New Outlook.Application
Dim oNamespace As Outlook.NameSpace
Dim oChildFolder As Outlook.MAPIFolder
ReDim m(2, 0)
Set oNamespace = oOutlook.GetNamespace("MAPI")
     For Each oChildFolder In oNamespace.Folders(1).Folders(FOLD).Folders
     Nm = oChildFolder.Name
     ST = (Replace(GetSetting("OUTL", "NASTR", Nm), ".", ",")) 'считываем коэффициент
     If ST <> "" Then ST = CDbl(Replace(ST, ".", ","))
  
     If ST = "" Then ' если не было коэффициента
     ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ST = InputBox("Введите коэффициент нагрузки для этого сотрудника", _
        "Сотрудник без коэффициента " & Nm, 1)
        If ST = "" Then
            MsgBox "Новому сотруднику писем не будет разноситься!", 64, ""
            SaveSetting "OUTL", "NASTR", Nm, 0 'запоминаем
            SaveSetting "OUTL", "NASTR", Nm & "_p", 0 'запоминаем
        Else
            SaveSetting "OUTL", "NASTR", Nm, ST 'запоминаем
            SaveSetting "OUTL", "NASTR", Nm & "_p", 0 'запоминаем
            
'            если появился новый сотрудник обнулим счётчики писем
            J = J + 1
            ReDim Preserve m(2, J)
            m(0, J) = Nm
            m(1, J) = ST
            m(2, J) = ST
            
            ReDim R(UBound(m, 2), UBound(m))
            
            For J = 1 To UBound(m, 2)
                 R(J, 0) = m(0, J)
                 R(J, 1) = m(1, J)
                 R(J, 2) = m(2, J)
            Next J
            
            For i = 1 To UBound(STR)
                SaveSetting "OUTL", "NASTR", STR(i, 0) & "_p", 0 'обнуляем ссётчики
            Next
 
        End If
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     Else
        J = J + 1
        ReDim Preserve m(2, J)
        m(0, J) = Nm
        m(1, J) = ST
        m(2, J) = P
     End If
     Next
     ReDim R(UBound(m, 2), UBound(m))
     For J = 1 To UBound(m, 2)
          R(J, 0) = m(0, J)
          R(J, 1) = m(1, J)
          R(J, 2) = m(2, J)
     Next J
     SOTR = R
End Function
 
Private Sub obnul()
Dim i
For i = 1 To UBound(STR)
SaveSetting "OUTL", "NASTR", STR(i, 0) & "_p", 0 'запоминаем
Next
End Sub