Outlook自动在新邮件及回复开头插入文本的VBA优化需求

核心修改点 #

• 移除.Display方法：直接修改邮件对象的HTMLBody属性，无需提前打开窗口，彻底解决双窗口冲突问题。
• 新增新邮件自动插入逻辑：通过Inspector事件监听新邮件创建动作，自动插入问候语。

修改后的完整代码 #

Public WithEvents GExplorer As Outlook.Explorer
Public WithEvents GMailItem As Outlook.MailItem
Public WithEvents GInspectors As Outlook.Inspectors

Private Sub Application_Startup()
  Set GExplorer = Outlook.Application.ActiveExplorer
  Set GInspectors = Outlook.Application.Inspectors
End Sub

Private Sub GExplorer_SelectionChange()
    Dim xItem As Object
    On Error Resume Next
    Set xItem = GExplorer.Selection.Item(1)
    If xItem.Class <> olMail Then Exit Sub
    Set GMailItem = xItem
End Sub

Private Sub GMailItem_Reply(ByVal Response As Object, Cancel As Boolean)
    AutoAddGreeting Response, True
End Sub

Private Sub GMailItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
    AutoAddGreeting Response, True
End Sub

Private Sub GInspectors_NewInspector(ByVal Inspector As Inspector)
    Dim xMailItem As MailItem
    On Error Resume Next
    Set xMailItem = Inspector.CurrentItem
    ' 判断是否为新创建的未发送邮件
    If Not xMailItem Is Nothing And xMailItem.Sent = False And xMailItem.EntryID = "" Then
        AutoAddGreeting xMailItem, False
    End If
End Sub

Sub AutoAddGreeting(Item As Object, IsReply As Boolean)
    Dim xGreetStr As String
    Dim xMail As MailItem
    Dim xTargetName As String
    Dim xRecipient As Recipient
    On Error Resume Next
    If Item.Class <> olMail Then Exit Sub
    Set xMail = Item
    
    ' 区分回复和新邮件的称呼逻辑
    If IsReply Then
        ' 回复时提取收件人名称（原邮件发件人）
        For Each xRecipient In xMail.Recipients
            If xTargetName = "" Then
                xTargetName = xRecipient.Name
             Else
                xTargetName = xTargetName & "," & xRecipient.Name
            End If
        Next xRecipient
    Else
        ' 新邮件默认称呼，可根据需求自定义
        xTargetName = "您好"
    End If
    
    ' 根据时间生成对应问候语
    Select Case Time
           Case 0.3 To 0.5
                xGreetStr = " 早上好！"
           Case 0.5 To 0.75
                xGreetStr = " 下午好！"
           Case Else
                xGreetStr = " 晚上好！"
    End Select
    
    ' 将问候语插入正文开头
    With xMail
        .HTMLBody = "Dear " & xTargetName & "," & xGreetStr & "<br><br>" & .HTMLBody
    End With
End Sub

代码说明 #

1. 回复/全部回复处理：保留原有的收件人名称拼接逻辑，直接修改回复邮件的HTML内容，不再调用.Display方法，避免弹出额外窗口，与预览窗格的回复保持一致。
2. 新邮件处理：通过GInspectors_NewInspector事件监听新邮件创建，判断为未发送的全新邮件时，自动插入预设问候语。
3. 自定义调整：新邮件的默认称呼可修改AutoAddGreeting子程序中Else分支的xTargetName值，比如改为具体称呼或留空。

使用步骤 #

1. 打开Outlook，按Alt+F11打开VBA编辑器。
2. 找到左侧的ThisOutlookSession模块，将上述代码粘贴进去。
3. 重启Outlook，代码即可自动生效。

内容的提问来源于stack exchange，提问作者Chasester