Скопируйте сообщение и отправьте с помощью VBA в Outlook

Question

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

    Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
  Dim outlookApp As Outlook.Application
  Dim objectNS As Outlook.Account

  Set outlookApp = Outlook.Application
  'Set objectNS = outlookApp.GetNamespace("MAPI")
  'Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
  Set objectNS = outlookApp.Session.Accounts.Item(2)
  Set inboxItems = objectNS.DeliveryStore.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
    MsgBox ("debug msg")

    Dim oNS As Outlook.NameSpace
    Set oNS = Application.GetNamespace("MAPI")

    Dim myItem As Outlook.MailItem
    Dim myRecipient As Outlook.Recipient
    Set myItem = Application.CreateItem(olMailItem)
    Set myRecipient = myItem.Recipients.Add("mail@mail.com")
    myItem.Subject = Item.Subject
    myItem.SendUsingAccount = oNS.Accounts.Item(2)
    myItem.HTMLBody = Item.Body
    myItem.Display
    'myItem.Send

End If
ExitNewItem:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ExitNewItem
End Sub

Скрипт автоматически запускается при запуске. Событие инициируется, когда в папке входящих сообщений появляется новый элемент. Так как у меня есть несколько учетных записей, связанных с Outlook. Я использую:

Set objectNS = outlookApp.Session.Accounts.Item(2)

Я не понимаю, почему тело сообщения не копируется (например, текст + картинка). Я пытался использовать:

myItem.HTMLBody = Item.RTFbody

или

myItem.HTMLBody = Item.HTMLbody

Но все равно сообщение остается пустым Скажите, что я делаю не так?

Answer 1

Тело сообщения может ссылаться на скрытые вложения, используемые для тегов img. Таким образом, если вы копируете разметку, возвращаемую свойством HTMLBody, вы также должны найти и повторно прикрепить изображения, используемые в теле. Кроме того, ваш код выглядит хорошо:

Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
    MsgBox ("debug msg")

    Dim oNS As Outlook.NameSpace
    Set oNS = Application.GetNamespace("MAPI")

    Dim myItem As Outlook.MailItem
    Dim myRecipient As Outlook.Recipient
    Set myItem = Application.CreateItem(olMailItem)
    Set myRecipient = myItem.Recipients.Add("mail@mail.com")
    myItem.Subject = Item.Subject
    myItem.SendUsingAccount = oNS.Accounts.Item(2)
    myItem.HTMLBody = Item.HTMLBody
    myItem.Display
    'myItem.Send

End If
ExitNewItem:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ExitNewItem
End Sub

В качестве обходного пути вы можете использовать методы Reply или Forward класса MailItem. Они оба возвращают объект MailItem, который представляет новый почтовый элемент. Таким образом, нет необходимости копировать что-либо. Вам просто нужны получатели, исправьте тему и вызовите метод Send. Например:

Sub Forwarding()  
 Dim myinspector As Outlook.Inspector  
 Dim myItem As Outlook.MailItem  
 Dim myattachments As Outlook.Attachments  

 Set myinspector = Application.ActiveInspector  
 If Not TypeName(myinspector) = "Nothing" Then  
 Set myItem = myinspector.CurrentItem.Forward  

 ' myItem.Display  
 myItem.Recipients.Add "Eugene Astafiev"  
 myItem.Send 

 Else  
 MsgBox "There is no active inspector."  
 End If  
End Sub

Answer 2

Работа с MailItem.Forward (Outlook)

Пример

Option Explicit
Public Sub Example()
    Dim Item As Outlook.MailItem
    Set Item = ActiveExplorer.Selection.Item(1)

    If TypeOf Item Is Outlook.MailItem Then
        Debug.Print Item.Subject
        FwItem Item
    End If

End Sub

Public Sub FwItem(ByVal Item As Object)
    Dim MsgFwd As Outlook.MailItem
    Set MsgFwd = Item.Forward
        MsgFwd.Subject = Item.Subject
        MsgFwd.Recipients.Add "0m3r@Email.com"
        MsgFwd.Save
        MsgFwd.HTMLBody = Item.HTMLBody
        MsgFwd.Send
End Sub