Public Sub Example(ByVal Tema As String)
    
    Dim OutApp As Outlook.Application
    Dim Namespace As Outlook.Namespace
    Dim Inbox As Outlook.MAPIFolder

    Set OutApp = New Outlook.Application 'активируем почту
    Set Namespace = OutApp.GetNamespace("MAPI") 'доступ ко всем данным Outlook, хранящимся в почтовых хранилищах пользователя.
'    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Inbox = Namespace.GetDefaultFolder(olFolderInbox) 'возвращается папка в коллекции папок

'   запускаем функцию - ищет письма с определенной темой во всех входящих с подпапками
    LoopFolders Inbox, Tema

    Set Inbox = Nothing
    
    MsgBox "Поиск писем закончен"
    
End Sub

Private Function LoopFolders(ByVal ParentFldr As Outlook.MAPIFolder, ByVal Tema As String)

    'тема письма, которую ищем
    Dim Subject As String
        Subject = Tema

'    Фильтр поиска по теме
    Dim Filter As String
    Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
                       Chr(34) & " >= '01/01/1900' And " & _
                       Chr(34) & "urn:schemas:httpmail:datereceived" & _
                       Chr(34) & " < '12/31/2100' And " & _
                       Chr(34) & "urn:schemas:httpmail:subject" & _
                       Chr(34) & "Like '%" & Subject & "%'"

    Dim Items As Outlook.Items
    Set Items = ParentFldr.Items.Restrict(Filter) 'возвращая новую коллекцию, содержащую все элементы из исходного объекта, которые совпадают с фильтром
        Items.Sort "[ReceivedTime]", False 'Сортирует коллекцию элементов по указанному свойству, по возрастанию
     
'    Если письмо с указанной темой было найдено
    If Items.Count <> 0 Then
        Found = True
        ' Для найденного письма формируем ответное письмо
        For Each itm In Items
          Set ReplyAll = itm.ReplyAll 'ответить всем в письме
            With ReplyAll
                .SentOnBehalfOfName = "#*@*.ru" ' Поле "От" если необходимо отправить письмо от рассылки
                .To = "#*@*.ru" 'Поле "Кому"
                .CC = "#*@*.ru" 'Поле "Копия"
                .Body = "blah blah hello world"  'вставить заготовку тескта-ответа
                .Display 'показать письмо
            End With
        Next
    End If
    
'    myOlApp.Quit
'    Set myOlApp = Nothing
    

    Dim SubFldr As Outlook.MAPIFolder
'   //Рекурсировать через SubFldrs
    If ParentFldr.Folders.Count > 0 Then
        For Each SubFldr In ParentFldr.Folders
            LoopFolders SubFldr, Tema
            Debug.Print SubFldr.Name
        Next
    End If
   
End Function

 'Создание и VBA-наименование объекта "DataObject".
    Dim myDataObject As New MSForms.DataObject

    'Очистка DataObject.
    myDataObject.Clear

    'Копирование текста в DataObject.
    myDataObject.SetText Text:=TextBox9.Text

    myDataObject.PutInClipboard

Dim txt$ 'переменная будет хранить комментарий
txt = TextBox18.Text

'Вызываем процедуру которая копирует данные
Call copytext(ByVal txt$)

'Функция копирования
Private Sub SetClipboardText(ByVal txt$)
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .SetText txt$
    .PutInClipboard
    End With
End Sub

'Процедура копирования по принципу ctr+C
Private Sub copytext(ByVal txt$)
    SetClipboardText (txt)
End Sub