为outlook添加邮件发送的确认提示框

在工作中，由于个人疏忽，经常会有发错邮件，或是邮件中遗漏附件等现象发生，为了预防这些问题，可以在发送邮件时利用相关的工具帮你自动检测出这些问题。
在网上搜了相关的问题，发现一段代码，但是代码里面有一些错误，导致无法正常使用，自己修改了一下：
主要实现了：
1、智能检测并提示附件遗漏
2、再次确认收件人
有需要的可以拿去用，不会用的请留言。
使用方法已添加。

源代码：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    Dim objRecip As Recipient
    Dim objContact As ContactItem
    Dim cancel_Attach As Boolean
    Dim intRes As Integer
    Dim strMsg As String
    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) = "附件"
    
    intOldmsgstart = InStr(Item.Body, "-----Original Message-----")
    If intOldmsgstart = 0 Then
        strThismsg = Item.Body + " " + Item.Subject
    Else
        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
        If Item.Attachments.Count = 0 Then
        strMsg = "附件检测器:" & Chr(13) & Chr(10) & "此邮件中提及附件，是否遗漏添加附件？" & Chr(13) & Chr(10) & "是否发送？"
        intRes = MsgBox(strMsg, vbYesNo + vbDefaultButton2 + vbExclamation, "Microsoft Outlook")
            If intRes = vbNo Then
                cancel_Attach = True
            End If
        End If
    End If
    
    Dim strTo As String
    Dim strCC As String
    Dim strBCC As String
    
    strTo = ""
    strCC = ""
    strBCC = ""
    
    If cancel_Attach = True Then
        Cancel = True
        Exit Sub
    End If
    
    If Item.MessageClass Like "IPM.TaskRequest*" Then
        Set Item = Item.GetAssociatedTask(False)
    End If
    
    For Each objRecip In Item.Recipients
        If LCase(objRecip.Address) Like "/o=*" Then
            If objRecip.Type = olTo Then
                strTo = strTo + objRecip.Name
            ElseIf objRecip.Type = olCC Then
                strCC = strCC + objRecip.Name
            ElseIf objRecip.Type = olBCC Then
                strBCC = strBCC + objRecip.Name
            End If
        End If
    Next
    
    MSGText = "主题：「" & Item.Subject & "」" & _
    vbCr & " 收信 : " & strTo & vbCr & " 抄送 : " & strCC & vbCr & " 密送 : " & strBCC & _
    vbCr & vbCr & "是否发送?"
    If MsgBox(MSGText, vbYesNo, "Microsoft Outlook") = vbNo Then
        Cancel = True
    End If

End Sub

使用方法：

工具栏添加开发工具

进入选项-> 自定义工具栏，确保开发工具被选中

添加代码

进入开发工具->Visual Basic，拷贝代码到文件

放开宏的启动权限

因为自己写的宏是没有数字证书的，所以需要调整宏的安全级别，不建议放到最低，使用提示即可。

效果展示