Как вставить таблицу после тела письма и до подписи?

Question

Я использую код ниже, который вставляет таблицу из Excel в файл Outlook. Однако сейчас таблица наклеена в самом низу письма - после подписи.

Чего я хотел бы добиться, так это вставить таблицу после слова «регион». а перед "С уважением" - так до подписи.

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
Dim myOutlook As Object
Dim myMailItem As Object
Dim mySubject As String
Dim myPath As String
Dim i As Integer
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

'Prompt for Email Subject

Set outlApp = CreateObject("Outlook.Application")
weeknumber = "Week " & WorksheetFunction.WeekNum(Now, vbMonday)
'mySubject = InputBox("Subject for Email")
For i = 2 To 3
region = Sheets("Sheet1").Cells(i, 5).Value
mySubject = "Overdue Milestones | " & weeknumber & " | " & region

'Copy every sheet from the workbook with this macro
Set Sourcewb = ActiveWorkbook
'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = "C:\Users\mxr0520\Desktop\Ignite Reports\Milestones\" & weeknumber
If i < 3 Then
MkDir FolderName
Else
End If
'Copy every visible sheet to a new workbook
Set sh = Sheets(region)
    'If the sheet is visible then copy it to a new workbook
    If sh.Visible = -1 Then
        sh.Copy
        'Set Destwb to the new workbook
        Set Destwb = ActiveWorkbook
        'Determine the Excel version and file extension/format
        With Destwb
            If Val(Application.Version) < 12 Then
                'You use Excel 97-2003
                FileExtStr = ".xls": FileFormatNum = -4143
            Else
                'You use Excel 2007-2016
                If Sourcewb.Name = .Name Then
                    MsgBox "Your answer is NO in the security dialog"
                    GoTo GoToNextSheet
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            End If
        End With
        'Change all cells in the worksheet to values if you want
        If Destwb.Sheets(1).ProtectContents = False Then
            With Destwb.Sheets(1).UsedRange
                .Cells.Copy
                .Cells.PasteSpecial xlPasteValues
                .Cells(1).Select
            End With
            Application.CutCopyMode = False
        End If
        'Save the new workbook, email it, and close it
        'Set otlNewMail = outlApp.CreateItem(myMailItem)

        Set OutLookApp = CreateObject("Outlook.application")
        Set OutlookMailitem = OutLookApp.CreateItem(0)
            With OutlookMailitem
            .display
            End With
            Signature = OutlookMailitem.htmlbody

        With Destwb
            .SaveAs FolderName _
                  & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                    FileFormat:=FileFormatNum
        End With
        myPath = ActiveWorkbook.path & "\" & ActiveWorkbook.Name
        With Destwb
            .Close False
        End With

        With OutlookMailitem
            .Subject = mySubject
            .To = Sheets("Sheet1").Cells(i, 6)
            .CC = Sheets("Sheet1").Cells(i, 7)
            .htmlbody = "Dear All," & "<br>" _
            & "<br>" _
            & "Attached please find the list of milestones that are <b>overdue</b> and <b>due in 14 days</b> for " & region & "." & "<br>" & "<br>" & "Regards," & "<br>" _
            & "Marek" _
            & Signature
            .Attachments.Add myPath

    Worksheets("Summary").Range("A1:E14").Copy
    Set vInspector = OutlookMailitem.GetInspector
    Set weditor = vInspector.WordEditor

    wEditor.Application.Selection.Start = Len(.body)
    wEditor.Application.Selection.End = wEditor.Application.Selection.Start
    wEditor.Application.Selection.Paste

            .display

        End With
        Set OutlookMailitem = Nothing
    End If

Заранее спасибо за помощь!

Answer 1

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

Затем просто создайте новый почтовый элемент с Set OutlookMailitem = OutlookApp.CreateItemFromTemplate({path to your template.oft}), замените заполнитель "region" и скопируйте / вставьте таблицу в местоположение заполнителя таблицы.

Option Explicit

Sub foo()

Dim objOutlook As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim wdDoc As Word.Document
Dim tblRange As Word.Range
Dim region As String
' define your Region, probably this is done in a loop...
region = "Region 1"
Set objOutlook = CreateObject("Outlook.Application")
' Create email from the template file // UPDATE WITH YOUR TEMPLATE PATH
Set objMsg = objOutlook.CreateItemFromTemplate("C:\path\to\your\template.oft")
objMsg.Display
Set wdDoc = objOutlook.ActiveInspector.WordEditor
' replace placeholder with region:
wdDoc.Range.Find.Execute "{{REGION PLACEHOLDER}}", ReplaceWith:=region
' in my template, paragraph 5 is the table placeholder, modify as needed:
Set tblRange = wdDoc.Range.Paragraphs(5).Range
tblRange.Text = ""  ' remove the placeholder text
' copy the Excel table // modify to refer to your correct table/range
Sheet1.ListObjects(1).Range.Copy
' paste the table into the email
tblRange.PasteExcelTable False, False, False

End Sub

Как видите, последнее письмо содержит мою подпись по умолчанию (которая была , а не частью файла template.oft).

Answer 2

Вы можете использовать следующие свойства для настройки тела сообщения:

1. Тело - строка, представляющая текст открытого текста элемента Outlook.

2. HTMLBody - строка, представляющая тело HTML указанного элемента.

3. Редактор слов. Свойство WordEditor класса Inspector возвращает экземпляр документа Word, который представляет тело сообщения. Вы можете найти все эти способы, описанные в Глава 17: Работа с телами предметов в MSDN .

Объектная модель Outlook не предоставляет каких-либо свойств или методов для обнаружения подписей. Вы анализируете тело сообщения и пытаетесь найти такие места.

Однако при создании подписи в Outlook три файла (HTM, TXT и RTF) создаются в следующих папках:

Vista и Windows 7/8/10 :

 C:\Users\<UserName>\AppData\Roaming\Microsoft\Signatures

Windows XP :

C:\Documents and Settings\<UserName>\Application Data\Microsoft\Signatures

Application Data и AppData - скрытые папки, измените представление в проводнике Windows, чтобы оно отображало скрытые файлы и папки, если вы хотите просмотреть файлы.

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