如何仅在新建Outlook邮件时运行指定VBA代码？

核心思路 #

通过判断邮件的MessageClass属性区分邮件类型：

• 新建邮件的MessageClass为 IPM.Note
• 回复邮件：IPM.Note.Reply
• 全部回复：IPM.Note.ReplyAll
• 转发邮件：IPM.Note.Forward

仅当邮件为IPM.Note时，执行字数统计与主题填充逻辑。

修改后的代码示例 #

场景1：邮件编辑时实时更新主题（监控正文变化） #

在ThisOutlookSession中添加以下代码：

Dim WithEvents myInspector As Outlook.Inspectors
Dim WithEvents myMailItem As Outlook.MailItem

Private Sub Application_Startup()
    Set myInspector = Application.Inspectors
End Sub

Private Sub myInspector_NewInspector(ByVal Inspector As Inspector)
    If TypeName(Inspector.CurrentItem) = "MailItem" Then
        Set myMailItem = Inspector.CurrentItem
    End If
End Sub

Private Sub myMailItem_PropertyChange(ByVal Name As String)
    ' 仅监控正文变化事件且仅处理新建邮件
    If (Name = "Body" Or Name = "HTMLBody") And myMailItem.MessageClass = "IPM.Note" Then
        Dim wordCount As Integer
        
        ' 根据邮件格式统计字数
        Select Case myMailItem.BodyFormat
            Case olFormatPlain, olFormatRichText
                wordCount = Len(Trim(myMailItem.Body))
            Case olFormatHTML
                ' 去除HTML标签和特殊字符后统计
                Dim cleanText As String
                cleanText = Replace(myMailItem.HTMLBody, "<[^>]*>", "", 1, -1, vbTextCompare)
                cleanText = Replace(cleanText, "&nbsp;", " ")
                wordCount = Len(Trim(cleanText))
        End Select
        
        ' 主题栏格式调整（可按需修改）
        If InStr(myMailItem.Subject, "[") = 0 Then
            myMailItem.Subject = "[" & wordCount & "字] " & myMailItem.Subject
        Else
            ' 若已有字数标记，更新数字
            myMailItem.Subject = Replace(myMailItem.Subject, "\[\d+字\]", "[" & wordCount & "字]", 1, -1, vbTextCompare)
        End If
    End If
End Sub

场景2：发送邮件前统一更新主题 #

如果不需要实时更新，仅在发送前处理，可使用ItemSend事件：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If TypeName(Item) = "MailItem" Then
        Dim mail As Outlook.MailItem
        Set mail = Item
        
        ' 仅处理新建邮件
        If mail.MessageClass = "IPM.Note" Then
            Dim wordCount As Integer
            
            Select Case mail.BodyFormat
                Case olFormatPlain, olFormatRichText
                    wordCount = Len(Trim(mail.Body))
                Case olFormatHTML
                    Dim cleanText As String
                    cleanText = Replace(mail.HTMLBody, "<[^>]*>", "", 1, -1, vbTextCompare)
                    cleanText = Replace(cleanText, "&nbsp;", " ")
                    wordCount = Len(Trim(cleanText))
            End Select
            
            mail.Subject = "[" & wordCount & "字] " & mail.Subject
        End If
    End If
End Sub

关键说明 #

• MessageClass判断是核心逻辑，确保代码仅作用于新建邮件
• HTML正文统计时，简单的标签替换可覆盖大部分场景；若需更高精度，可通过Word对象解析HTML内容（需注意Outlook与Word的兼容性）
• 主题栏的格式可根据个人需求自由调整，比如去掉前缀、修改标记样式等

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