outlook发邮件前跳出检查设置

maytoper

我们公司最近经常有人发错邮件，要么有附件忘记加了，要么没写标题，要么就发错对象了，现在想在发邮件前检测下各项条件是否符合。我们公司用的是exchange2007做的服务器，上面有3个域名做邮箱后缀。
我找了半天，综合了一段代码，但是在获取收件人地址时和想达到自己目标的功能有一定差距。
现在的代码能得到邮件地址并提示，但是不能区分收件人，抄送，密超，还有就是想做到针对@a.com  @b.com  @c.com的自己公司的域内邮件不作检查，只针对非这3个域名后缀的收件人弹出确认窗口
代码目的：
1，检查是否写标题   （目前的代码已经解决）
2，正文有附件的字样，但没加附件    （目前的代码已经解决）
3，能弹出提示：要向下面的地址发送邮件，确定吗？并分别列出收件人，抄送，密抄；同时针对@a.com  @b.com  @c.com这3个域名后缀的邮件地址不作提示（不管在收件人里还是在抄送里）.
4，最好还能检测下当前发送账户（因为我们有部分人有2-3个账户分别用来对应不同的客户）


代码如下：

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
cancel_Subject = MsgBox("此封邮件没有标明主题" & vbNewLine & _
"是否继续发送？", _
vbYesNo + vbExclamation, "空主题") = vbNo
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 objContact Is Nothing Then
            If LCase(objRecip.Address) Like "/o=*" Then
                strExternal = strExternal & "内部邮件地址：      " & objRecip.Name & vbCr
            Else
                strExternal = strExternal & "外部邮件地址：      " & objRecip.Name & vbCr
            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

[ 本帖最后由 maytoper 于 2011-8-10 19:29 编辑 ]

dsd999

你列的3和4没实现吗？

maytoper

没有啊，
3的功能现在只能做到提示，但做不到分类！！！而且貌似采用的是联系人做比对，有联系人的话直接就不提示了！
4的功能没做也就没实现了！

dsd999

3的功能现在只能做到提示，但做不到分类！！！而且貌似采用的是联系人做比对，有联系人的话直接就不提示了！


这句没看明白。

maytoper

就是想实现对内部地址不提示，只要不是对公司的邮箱发邮件，就需要跳出来窗口 去让你确认需要发送的地址
而分类呢主要是指：TO CC BCC 三栏分开显示，例如显示
向下列外部地址发送邮件：
收件人地址：1@1.com
            2@2.com
抄送地址：3@3.com
                    4@4.com
密抄地址：5@5.com

现在的这段代码只能笼统的显示  
  内部地址：xxxxx@xxxxxx.com  
    外部地址   xxxxxx@xxxxx.com

maytoper

看下图的效果

[ 本帖最后由 maytoper 于 2011-8-11 11:43 编辑 ]

maytoper

弄了半天还是不行啊！！！

dsd999

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

'Dim abc As Outlook.mailItem
'  abc = Set_Account("m", Item)

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
cancel_Subject = MsgBox("此封邮件没有标明主题" & vbNewLine & _
"是否继续发送？", _
vbYesNo + vbExclamation, "空主题") = vbNo
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

Dim strTo As String
Dim strCC As String
Dim strBCC As String

strTo = ""
strCC = ""
strBCC = ""

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 objContact Is Nothing Then
'            If LCase(objRecip.Address) Like "/o=*" Then
'                strExternal = strExternal & "内部邮件地址：      " & objRecip.Name & vbCr
'            Else
'                strExternal = strExternal & "外部邮件地址：      " & objRecip.Name & vbCr
'            End If
'        End If
     If Not LCase(objRecip.Address) Like "/o=*" Then
     
        If InStr(1, Item.To, objRecip.Name) <> 0 Then
        strTo = strTo + objRecip.Name
        ElseIf InStr(1, Item.CC, objRecip.Name) <> 0 Then
        strCC = strCC + objRecip.Name
        ElseIf InStr(1, Item.BCC, objRecip.Name) <> 0 Then
        strBCC = strBCC + objRecip.Name
        End If
     
     End If
    Next
   
   
                  MSGText = "主题：「" & Item.Subject & "」" & vbCr & "要向下面的地址发送邮件，确定吗？" & _
        vbLf & "收信人地址:" & vbCr & strTo & vbCr & " 抄送 : " & strCC & vbCr & " 密送 : " & strBCC
        If MsgBox(MSGText, vbYesNo, "发送确认") = vbNo Then
            Cancel = True
        End If
End Sub

dsd999

试试，有问题再上来问。

maytoper

谢谢老大，基本解决了，只剩下2个方面没有解决
1，就是对内部发送也会跳出提醒窗口，能否做到对内部发送不提醒，有外部地址的才提醒。因为对内部邮件发送量还是比较大的！
2，就是获取现发件人的发件帐号提醒（这条难做的话，可以暂时不做）