忘记帖附件？让Outlook自动提示

原文地址：http://blog.sina.com.cn/s/blog_660c623c0100timt.html

由于签名中的图片也算作是附件，在原文的基础上，将签名中的图片被算作附件这种情况也处理了一下。我用的是Outlook 2010。

　　今天回一封重要邮件时又忘了帖附件，实在是很失礼的行为啊……想到这种事情以前也发生过几次，就希望自己动手丰衣足食一下。在网上搜了一下，果然找到了一个不错的VBA， 按照自己的情况 改动了一下，加入了对复杂情况的识别功能，并加了注释。效果还不错，帖出来供有缘人使用。
　　P.S. 科研人员和白领还是用Outlook或者Foxmail收发邮件吧，尽量少用Web客户端，尽管我承认一些Web客户端做得很不错（如Gmail就带有附件提醒功能）。对于商务应用和其它正式场合，用Web收发邮件就像用Web上水木一样，感觉就像穿背心裤衩拖鞋出席正式酒宴一样。另外Outlook的确是一个现代人的好帮手，如果你有一台WM平台的智能手机又会编程的话就更加如虎添翼了。
　　原帖位于http://hi.baidu.com/ʫչ/blog/item/c7f8dff9d032d658242df275.html，更需要感谢的是代码的最初作者Dan Evans（dan@danevans.co.uk）.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    ' 只检查邮件类型
    If TypeName(Item) <> "MailItem" Then Exit Sub
   
    Dim intRet As Integer
    Dim strMsg As String
   
    ' 空主题？
    If Item.Subject = "" Then
        strMsg = "您的邮件缺少主题，返回填写吗？" & vbCrLf & "没有主题的邮件可不礼貌哦～"
        intRet = MsgBox(strMsg, vbYesNo + vbExclamation, "缺少主题")
        If intRet = vbYes Then
            Cancel = True
            Exit Sub
        End If
    End If
   
    ' 忘了帖附件？
    Dim intRes As Integer
    Dim strThismsg As String
    Dim intOldmsgstart As Integer
   
    Dim sSearchStrings(2) As String
    Dim bFoundSearchstring As Boolean
    Dim i As Integer
   
    ' 指定提示邮件可能需要附件的词
    bFoundSearchstring = False
    ' 英文邮件
    sSearchStrings(0) = "attach"
    sSearchStrings(1) = "enclose"
    ' 中文邮件
    sSearchStrings(2) = "附件"
   
    ' 对于转发和回复的邮件，不要到信末附的邮件原文进行搜索
    ' 纯文本格式的原文信头是“Original Message”或“邮件原件”，但HTML格式的回复没有
    intOldmsgstart = InStr(Item.Body, "发件人:")
    ' 如果在邮件国际选项中打开了“答复和转发时邮件头使用英语”，则应该搜索英文信头
    ' intRes作为临时变量
    intRes = InStr(Item.Body, "From:")
    ' 对于多次回复和转发又有多种语言的情况，总是选择最上一封
    If intRes > 0 Then
        If (intOldmsgstart = 0) Or (intOldmsgstart > 0 And intRes < intOldmsgstart) Then
            intOldmsgstart = intRes
        End If
    End If
   
    If intOldmsgstart = 0 Then
        ' 不是Re/Fw的邮件则搜索邮件全文和主题
        strThismsg = Item.Body + " " + Item.Subject
    Else
        ' 是Re/Fw的邮件则只搜索用户写的部分和邮件主题
        strThismsg = Left(Item.Body, intOldmsgstart) + " " + Item.Subject
    End If
   
    ' 搜索邮件正文（和主题）中所有可能提示邮件需要附件的词
    For i = LBound(sSearchStrings) To UBound(sSearchStrings)
        If InStr(LCase(strThismsg), sSearchStrings(i)) > 0 Then
            bFoundSearchstring = True
            Exit For
        End If
    Next i
   
    If bFoundSearchstring Then
        ' 下面的代码是将签名中的图片排除在附件之外，image001.jpg是我机器上签名里图片的文件名，请按实际情况调整
        Dim bSignature As Boolean
        
        For Each attach In Item.Attachments
            If attach.FileName = "image001.jpg" Then
                bSignature = True
            End If
        Next
        
        If Item.Attachments.Count = 0 Or (Item.Attachments.Count = 1 And bSignature) Then
            strMsg = "您的邮件可能缺少附件！" & vbCrLf & "是否仍要发送？"
            intRet = MsgBox(strMsg, vbYesNo + vbDefaultButton2 + vbExclamation, "缺少附件")
            If intRet = vbNo Then
                Cancel = True
                Exit Sub
            End If
        End If
        
    End If
End Sub

以上代码在Outlook 2007下运行通过，2003应该也可以。
使用方法：
（1）打开Outlook；
（2）按Alt + F11打开VBA；
（3）点击左侧树状目录最下面的“ThisOutlookSession”，看到右边出现空白的编辑窗口；
（4）把上面的代码复制到编辑窗口，保存即可。不用重启Outlook.
如果不改变Outlook的默认宏安全性设置，重启之后宏就会被禁用，可以调低宏安全性解决这个问题（Outlook界面的“工具”->“宏”->“安全性”），但这样会使Outlook受到宏病毒的威胁。最好的办法是在Office工具里的“VBA项目数字证书”给自己发一个数字证书，再用这个证书给自己写的宏进行数字签名（在VBA界面下的“工具”->“数字签名”）。进行数字签名之后重启Outlook，Outlook会提示发现新的已签名的宏，再选择“信任该证书签署的宏”（大概是这名字）即可。这样自己写的宏不会再得到警告，其它的宏仍然会受警告，从而避免中毒。