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

这段代码将我定义的文本添加到新编写的电子邮件的最后一段之后

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

私有子应用程序\u ItemSend（ByVal项作为对象，取消作为布尔值）
将收件人设置为Outlook.Recipients
将recip设置为Outlook.recipient
将pa设置为Outlook.PropertyAccessor
Dim提示符、strMsg、myText作为字符串
Dim NewMail作为邮件项，oInspector作为检查器
myText=“此处是要添加的文本”
常量PR_SMTP_地址作为字符串=”http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
设置recips=Item.Recipients
对于recips中的每个recips
设置pa=recip.PropertyAccessor
如果InStr（LCase（pa.GetProperty（PR_SMTP_地址）），“@nhs.net”）=0，则
strMsg=strMsg&&pa.GetProperty（PR\u SMTP\u地址）&vbNewLine
如果结束
下一个
设置oInspector=Application.ActiveInspector
如果幽灵什么都不是
MsgBox“无活动检查器”
其他的
设置NewMail=oInspector.CurrentItem
如果是新邮件，那么发送
MsgBox“这不是可编辑的电子邮件”
其他的
如果是oInspector.IsWordMail，则
Dim oDoc作为对象，oWrdApp作为对象，oSelection作为对象
设置oDoc=oInspector.WordEditor
设置oWrdApp=oDoc.Application
如果strMsg=“”，则“所有收件人都是该组织的内部人员。
'将联系人行添加到签名底部
oWrdApp.ActiveDocument.Content.InsertAfter myText
使用oWrdApp.ActiveDocument.Content.parations.Last
.Range.Font.Bold=True
.Alignment=wdAlignParagraphCenter
以
如果结束
设置oWrdApp=Nothing
设置oDoc=无
如果结束
如果结束
如果结束
端接头

在新邮件中，如果所有收件人都是NHS（@NHS.net域）的内部收件人，则会在签名下方添加一条联系电话

亲爱的某人，
这是我电子邮件的正文
亲切的问候，
商标

这是我的签名
**这是VBA添加的行**

如果我回复电子邮件或转发电子邮件（所有收件人都是组织内部的），我会错误地得到：

大家好，
谢谢你的回复。以下是我的想法

很高兴收到你的来信，
商标

这是我的签名

---

发件人：某人
发送：某个时间

嗨，TM，
这是对您原始电子邮件的回复
谢谢，
某人

---

From:TM
已发送：初始电子邮件
亲爱的某人，
这是我电子邮件的正文
亲切的问候，
商标

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

---

我不知道它是否会在邮件实际发送时起作用（

Application.ItemSend

event），但当检查器仍处于活动状态时，您可以使用“\u 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

---

在此之前，我会建议将不可靠的“From:”作为新文本和原始文本之间的分界点

现在，如果书签“\u 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

私有子应用程序\u ItemSend（ByVal项作为对象，取消作为布尔值）
将收件人设置为收件人
作为收件人的Dim recip
Dim pa作为物业接受者
作为字符串的Dim strMsg
将myText设置为字符串
检查员作为检查员
作为对象的Dim-oDoc
作为对象的Dim oBkm
作为对象的Dim oSel
myText=“此处是要添加的文本”
常量PR_SMTP_地址作为字符串=”http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
设置recips=Item.Recipients
对于recips中的每个recips
设置pa=recip.propertyAccessor
如果InStr（LCase（pa.GetProperty（PR_SMTP_地址）），“@nhs.net”）=0，则
strMsg=pa.GetProperty（PR\u SMTP\u地址）&vbNewLine
退出“一个收件人已足够”
如果结束
下一个
如果strMsg“”则
“所有接受者都是组织内部人员。
后藤
如果结束
设置oInspector=Item.GetInspector
如果是oInspector.IsWordMail，则
设置oDoc=oInspector.WordEditor
如果存在oDoc.Bookmarks（“\u maildoriginal”），则
设置oBkm=oDoc.Bookmarks（“\u maildoriginal”）
oBkm.选择
设置oSel=oDoc.Windows（1）.选择
用欧塞尔
.InsertBefore myText和vbNewLine
崩溃
.MoveEnd单位：=wdLine，计数：=1
.Font.Bold=True
.ParagraphFormat.Alignment=wdAlignParagraphCenter
以
其他的
'将联系人行添加到签名底部
myText后面的oDoc.Content.insert
带oDoc.Content.parations.last
.Range.Font.Bold=True
.Alignment=wdAlignParagraphCenter
以
如果结束
如果结束
现存的：
设置recips=Nothing
设置recip=Nothing
设置pa=无
设置oInspector=Nothing
设置oDoc=无
设置oBkm=无
设置oSel=无
端接头

您好，谢谢您修改代码。我测试了它，当转发和回复时，它的行为与当前代码相同。我也尝试过“\u MailAutoSig”，但没有骰子，可能是因为它是Outlook 2007，实际上“\u MailAutoSig”书签是隐藏的，“\u MailOriginal”不存在！