Как искать элементы с вложением и ключевым словом в теме с помощью фильтра

Я работаю над кодом, вложение которого будет загружено в папку в контексте темы с помощью фильтра темы.

После долгого поиска в Интернете мой код работает, но проблема в том, что я хочу поместить ключевое слово в фильтр темы, чтобы он загружал вложение, поскольку тема меняется каждый день.

например Sub: training_24357 в один день и training_24359 на следующий день.

Кроме того, я хочу автоматически запускать свой код каждые 5 минут, любая помощь будет очень признательна,

ниже мой код.

Sub Attachment()

    Dim OutOpened As Boolean
    Dim App As Outlook.Application
    Dim Ns As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder
    Dim Attach As Outlook.Attachment
    Dim Item As Object
    Dim MailItem As Outlook.MailItem
    Dim subject As String
    Dim saveFolder As String
    Dim dateFormat As String

    saveFolder = "D:\Outlook\POS Visit Report"
    If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"

        subject = """*POS Visit*"""

        OutOpened = False
        On Error Resume Next
        Set App = GetObject(, "Outlook.Application")
        If Err.Number <> 0 Then
            Set App = New Outlook.Application
            OutOpened = True
        End If
   On Error GoTo 0
        If App Is Nothing Then
            MsgBox "Cannot Start Outlook Mail", vbExclamation
            Exit Sub
        End If
    Set Ns = App.GetNamespace("MAPI")
    Set Folder = Ns.GetDefaultFolder(olFolderInbox)

        If Not olFolder Is Nothing Then
            For Each Item In olFolder.Items
                If Item.Class = Outlook.ObjectClass.olMail Then
                    Set MailItem = Item
                    If MailItem.subject = subject Then
                        Debug.Print MailItem.subject
                        For Each Attach In MailItem.Attachments
                        dateFormat = Format(Now(), "yyyy-mm-dd H-mm")
                        Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
                        Next
                    End If
                End If
            Next
        End If


    If OutOpened Then App.Quit
    Set App = Nothing

End Sub