Добавление текста под подписью в ответ и переслать - PullRequest
0 голосов
/ 24 июня 2018

Этот код добавляет мой определенный текст после последнего абзаца вновь составленных писем.

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

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.recipient
Dim pa As Outlook.PropertyAccessor
Dim prompt, strMsg, myText As String
Dim NewMail As MailItem, oInspector As Inspector

myText = "HERE IS THE TEXT TO BE ADDED"


Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

Set recips = Item.Recipients
For Each recip In recips
    Set pa = recip.PropertyAccessor
    If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@nhs.net") = 0 Then
        strMsg = strMsg & "   " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
    End If
Next


Set oInspector = Application.ActiveInspector
If oInspector Is Nothing Then
    MsgBox "No active inspector"
Else
    Set NewMail = oInspector.CurrentItem
    If NewMail.Sent Then
        MsgBox "This is not an editable email"
    Else
        If oInspector.IsWordMail Then

            Dim oDoc As Object, oWrdApp As Object, oSelection As Object
            Set oDoc = oInspector.WordEditor
            Set oWrdApp = oDoc.Application

                If strMsg = "" Then 'All the recipients are internal to the organisation.

                    'Add contact line to bottom of signature
                     oWrdApp.ActiveDocument.Content.InsertAfter myText
                       With oWrdApp.ActiveDocument.Content.Paragraphs.Last
                          .Range.Font.Bold = True
                          .Alignment = wdAlignParagraphCenter
                        End With
                End If

            Set oWrdApp = Nothing
            Set oDoc = Nothing

        End If
    End If
End If
End Sub

В новом сообщении, в котором все получатели являются внутренними для NHS (домен @ nhs.net), под подписью будет добавлена ​​контактная строка.

Дорогой,
Вот тело моего письма!
С уважением,
TM

Вот мой знак
** и здесьэто строка, добавленная VBA **

Если я отвечаю на электронное письмо или пересылаю электронное письмо (и все получатели являются внутренними для организации), я неправильно получаю:

Привет, кто-нибудь,
Спасибо за ваш ответ.Вот что я думаю ......

Рад тебя слышать,
ТМ

Вот мой сигнал


От кого-то
Отправлено: Когда-нибудь

Привет ТМ,
Вот ответ на ваш оригинальный адрес электронной почты!
Спасибо,
Кто-нибудь


От: ТМ
Отправлено:Начальная электронная почта
Дорогой,
Вот тело моего письма!
С уважением,
TM

Вот мой подпись
** и вот добавленная строкаVBA первоначально **
**** Это строка, добавленная VBA, когда я отвечаю, или fwd ****
****. Это должно быть ниже подписив электронном письме, которое в настоящее время составляется !!

Ответы [ 2 ]

0 голосов
/ 25 июня 2018

Ранее я бы предложил ненадежное «От:» в качестве точки разграничения между новым и исходным текстом.

Теперь, имея закладку "_MailOriginal", которая выглядит надежной, вы можете вставить ее выше этой точки.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim recips As Recipients
Dim recip As Recipient

Dim pa As propertyAccessor

Dim strMsg As String
Dim myText As String

Dim oInspector As Inspector

Dim oDoc As Object

Dim oBkm As Object
Dim oSel As Object

myText = "HERE IS THE TEXT TO BE ADDED"

Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

Set recips = Item.Recipients

For Each recip In recips
    Set pa = recip.propertyAccessor
    If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@nhs.net") = 0 Then
        strMsg = pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
        Exit For    'One recipient is enough
    End If
Next

If strMsg <> "" Then
    'All the recipients are internal to the organisation.
    GoTo ExitRoutine
End If

Set oInspector = Item.GetInspector

If oInspector.IsWordMail Then

    Set oDoc = oInspector.WordEditor

    If oDoc.Bookmarks.exists("_MailOriginal") Then

        Set oBkm = oDoc.Bookmarks("_MailOriginal")
        oBkm.Select
        Set oSel = oDoc.Windows(1).Selection

        With oSel
            .InsertBefore myText & vbNewLine
            .Collapse
            .MoveEnd Unit:=wdLine, count:=1
            .Font.Bold = True
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
        End With

    Else

        'Add contact line to bottom of signature
        oDoc.Content.InsertAfter myText
        With oDoc.Content.Paragraphs.last
            .Range.Font.Bold = True
            .Alignment = wdAlignParagraphCenter
        End With

    End If

End If

ExitRoutine:
    Set recips = Nothing
    Set recip = Nothing
    Set pa = Nothing

    Set oInspector = Nothing
    Set oDoc = Nothing
    Set oBkm = Nothing
    Set oSel = Nothing

End Sub
0 голосов
/ 24 июня 2018

Я не знаю, сработает ли это к моменту фактического отправки сообщения (событие Application.ItemSend), но пока инспектор все еще активен, вы можете найти начало исходного письма, используя "_MailOriginal"закладка.Затем вы можете вставить свой текст прямо перед ним.objDoc ниже прибывает из Inspector.WordEditor

If objDoc.Bookmarks.Exists("_MailOriginal") Then
  set objBkm = objDoc.Bookmarks("_MailOriginal")
  objSel.Start = objBkm.Start-2 'give room for the line break before. It includes the line
End If
...