在回复和转发时在签名下添加文本

时间:2018-06-24 09:15:42

标签: outlook-vba

此代码在新撰写的电子邮件的最后一段之后添加了我定义的文本。

在撰写答复或要转发的内容时,我需要标识签名下方的区域,因为代码会将我的文本添加到整个电子邮件线程的最后一段。

py2neo

在一条新消息上,所有收件人都位于NHS(@ nhs.net域)内部,一条联系线将添加到签名下方。

  

亲爱的人,
      这是我的电子邮件正文!
      亲切的问候,
      TM

     

这是我的信号
      **这是VBA添加的行**

如果我回复电子邮件或转发电子邮件(并且所有收件人都在组织内部),我会错误地得到:

  

嗨,某人,
      感谢您的回复。这就是我的想法……

     

很高兴收到您的来信,
      TM

     

这是我的信号

     
     

来自:某人
      发送:某个时间

     

嗨TM,
      这是您原始电子邮件的回复!
      谢谢
      有人

     
     

来自:TM
      已发送:初始电子邮件
      亲爱的某人,
      这是我的电子邮件正文!
      亲切的问候,
      TM

     

这是我的信号
      **这是VBA最初添加的行 **
      ****这是VBA在我回复或转发时添加的行****
      ****必须在当前正在起草的电子邮件中的签名下方!

2 个答案:

答案 0 :(得分:0)

我不知道在实际发送邮件之前(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

答案 1 :(得分:0)

以前,我会建议使用不可靠的“发件人:”作为新文本和原始文本之间的分界点。

现在给出看起来可靠的书签“ _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