'Удаленные ==> GetDefaultFolder(3)
'Исходящие ==> GetDefaultFolder(4)
'Отправленные ==> GetDefaultFolder(5)
'Входящие ==> GetDefaultFolder(6)

Public Function MassPattern(ByVal GetDefaultFolder%, ByVal Pattern$)
    Dim objOutlApp As Object, oMail As Object
    Dim m(), i%, T
    Dim IsNotAppRun As Boolean

    Application.ScreenUpdating = False

    'подключаемся к Outlook
    On Error Resume Next
    Set objOutlApp = GetObject(, "outlook.Application")
    If objOutlApp Is Nothing Then
        Set objOutlApp = CreateObject("outlook.Application")
    End If

    i% = 1
    For Each oMail In objOutlApp.GetNamespace("MAPI").GetDefaultFolder(GetDefaultFolder%).items
        If oMail.Subject Like "*" & Pattern$ & "*" Then
            ReDim Preserve m(i%)
            m(i%) = oMail.Subject & "_" & oMail.CreationTime
            'oMail.Delete
            Sleep (1)
            i% = i% + 1
        End If
    Next

    'Если приложение Outlook было открыта кодом - закрываем
    If IsNotAppRun Then
        objOutlApp.Quit
    End If
    Set objOutlApp = Nothing
    'возвращаем ранее отключенное обновление экрана
    MassPattern= m
    Application.ScreenUpdating = True
    ' End If
End Function

'задержка
Private Function Sleep(TimeSleep As Double)
    Dim Chas As Date, Z#, T As Date
    Chas = Timer()
    Z = Chas + TimeSleep
1:
    T = Timer()
    DoEvents
    If T < Z Then GoTo 1
End Function