Это должно работать для вас, если соответствующим источником вложения является встроенный элемент, например встроенное изображение. Я не пробовал его с вложенными файлами, которые не являются встроенными, но он может работать там же. Основные идеи:
1) Рассматривайте содержимое электронных писем как документ Word, поскольку собственным редактором для Outlook является Word.
2) Используйте Word's Copy and Paste, чтобы переносить все с собой через буфер обмена, потому что это хорошо проверенный подход. В этом примере я вставил новый раздел с самого начала в новый абзац, но вы, очевидно, можете разместить его в любом месте.
Странно, однако, (см. Debug.Print
), что количество вложений в документе To не изменяется, даже если встроенные изображения находятся там, где они должны быть, их можно увидеть и отправить. Приятного просмотра! (Файлы .olm
в примере - это просто Outlook.MailItems, которые были сохранены как файлы шаблонов. Они также могут быть MailItems из папки Outlook.)
Private Sub TestAttach()
'Places inline Attachment information into a different MailItem
Dim OlTo As Outlook.MailItem
Dim OlFrom As Outlook.MailItem
Dim DocTo As Word.Document
Dim DocFrom As Word.Document
Dim R As Word.Range
Dim R1 As Word.Range
Dim R2 As Word.Range
Dim lStart As Long
Dim lEnd As Long
Set OlFrom = Outlook.CreateItemFromTemplate("C:\Temp\OlTemplateWithSomeOtherAttachments.oft")
Set OlTo = Outlook.CreateItemFromTemplate("C:\Temp\OlTemplateWithSomeAttachments.oft")
Debug.Print "From file starts with " & OlFrom.Attachments.Count & " attachments."
Debug.Print "To file starts with " & OlTo.Attachments.Count & " attachments."
Set DocFrom = OlFrom.GetInspector.WordEditor
Set DocTo = OlTo.GetInspector.WordEditor
OlFrom.Display
OlTo.Display
Set R2 = DocFrom.Content
With R2.Find 'Note: Find settings are 'sticky' and do not need to be repeated on the next find.
.Forward = True
.Wrap = wdFindStop 'Do not loop back to the start of the document
.Format = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Text = "Start flag for Section with Attachments" 'Find the start of the section to move
.Execute
lStart = R2.Start
.Text = "End flag for Section with Attachments" 'Find the end of the section to move
R2.Collapse wdCollapseEnd
.Execute
lEnd = R2.Start
End With
'OlFrom.Display
Set R2 = DocFrom.Range(lStart, lEnd)
'R2.Select
R2.Copy
Set R = DocTo.Range(1, 1)
R.InsertParagraphBefore
'Place the new inline attachments in the To MailItem
Set R = DocTo.Range(1, 1)
R.Paste
OlTo.Display
Debug.Print OlTo.Attachments.Count; "To file ends with " & OlTo.Attachments.Count & " attachments, the same as the original number but all the inline images show."
End Sub