Сохранение данных письма, на которое происходит ответ. Макросом в Excel VBA

[Lena_VVV]

Друзья всем привет, помогите пожалуйста с такой проблемой: есть макрос в excel, который ищет письмо по указанной теме во всех входящих папках Outlook, затем отвечает на найденное письмо с определенным текстом, в который будет состоять в том числе из переменной равной теме письма. Когда я вставляю тело письма "".Body = "blah blah hello world" весь текст предыдущего стирается, остается только   "blah blah hello world. Как оставить весь текст предыдущего письма и поля  From..., СС.. и т. д предыдущего письма, которые автоматически формируется если отвечаешь на какое-либо письмо?
Всем спасибо за помощь)

Код (vb) Выделить Развернуть

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

[vikttur]

Обсуждение