Outlook发邮件时检查是否有外部收件人，如果有给提警告提示，检查是否忘记写主题等

效果图:

以下为VBA代码，打开OUTLOOK按ALT+F11,复制以下代码，粘贴进去就行了

==================

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

    Dim objRecip As Recipient

    Dim objContact As ContactItem

    Dim strExternal As String

    Dim cancel_Subject As Boolean

    Dim cancel_Attach As Boolean

'检查邮件是否有标题

If Item.Subject = "" Then

Application.Explorers(1).Activate

lngres = MsgBox("邮件还没有写主题,请按公司要求填写邮件主题" & Chr(10) & "不理它仍然发送？", _

vbYesNo + vbDefaultButton2 + vbQuestion, "邮件没有标题的提示")

If lngres = vbNo Then

Cancel = True

Item.Display

Exit Sub

End If

End If

    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, "你忘记添加附件!")

If intRes = vbNo Then

cancel_Attach = True

End If

End If

End If

'检查是否有外部收件人地址

If (cancel_Subject Or cancel_Attach) = True Then

Cancel = True

End If

    If Item.MessageClass Like "IPM.TaskRequest*" Then

        Set Item = Item.GetAssociatedTask(False)

    End If

    strExternal = ""

    For Each objRecip In Item.Recipients

        Set objContact = FindContactByAddress(objRecip.Address)

        If LCase(objRecip.Address) Like "[email protected]

" = False Then '功能开关-如果包含有外部邮件地址时，才提醒，全是内部邮件不提醒

        If objContact Is Nothing Then

            If LCase(objRecip.Address) Like "[email protected]

" Then '分开列出外部和内部邮件地址

                strExternal = strExternal & "内部邮件地址：" & objRecip.Name & vbCr

           Else

                strExternal = strExternal & "外部邮件地址：" & objRecip.Name & vbCr

            End If

      End If

      End If

    Next

    If strExternal <> "" Then

                  MSGText = "主题：「" & Item.Subject & "」" & vbCr & "提示：请仔细检查，要向下面的地址发送邮件，确定吗？" & _

        vbLf & "收信人地址:" & vbCr & strExternal

        If MsgBox(MSGText, vbYesNo, "发送确认") = vbNo Then

            Cancel = True

        End If

    End If

End Sub

Private Function FindContactByAddress(strAddress As String)

    Dim objContacts

    Dim objContact

    Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts)

    Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _

        & "' or [Email2Address] = '" & strAddress _

        & "' or [Email3Address] = '" & strAddress & "'")

    Set FindContactByAddress = objContact

End Function

=================