OUTLOOK有条件的密送功能

solonely

闻启学 发表于 2015-9-9 22:53
给个附件我 看看

就是下面这段代码,第27行就停止了

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objRecip As Recipient
    Dim strMsg As String
    Dim res As Integer
    Dim strBcc As String
    On Error Resume Next
    Dim myItem As outlook.MailItem

    Dim arrto
    Dim arrcc

    Dim myTo As String

    Dim mycc As String

    Set myItem = Item

                '这里填写你要密送的邮箱


    Debug.Print myItem.CC; myItem.To

    arrto = Split(myItem.To, ";")

    arrcc = Split(myItem.CC, ";")

Stop
    For i = 0 To UBound(arrto)

        If Not arrto(i) Like "*@163.com" Then


            strBcc = strBcc & arrto(i) & ";"

            arrto(i) = ""
        End If

    Next
   
    Stop
    myTo = Join(arrto, ";")

    For i = 0 To UBound(arrcc)

        If Not arrcc(i) Like "*@163.com" Then

            strBcc = strBcc & arrcc(i) & ";"
            arrcc(i) = ""

        End If

    Next
Stop
    mycc = Join(arrcc, ";")
   

    Set objRecip = myItem.Recipients.Add(strBcc)
   
    myItem.To = Trim(myTo)
   
    myItem.CC = Trim(mycc)
   
    Stop
    objRecip.Type = olBCC
    If Not objRecip.Resolve Then
        strMsg = "不能解析密件抄送人邮件地址， " & _
                 "请确认是否仍然发送邮件？"
        res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
                     "不能解析密件抄送人邮件地址")
        If res = vbNo Then
            Cancel = True
        End If
    End If

    Set objRecip = Nothing


End Sub

闻启学

哦哦哦  sorry 我忘记删除测试代码

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objRecip As Recipient
    Dim strMsg As String
    Dim res As Integer
    Dim strBcc As String
    On Error Resume Next
    Dim myItem As outlook.MailItem

    Dim arrto
    Dim arrcc

    Dim myTo As String

    Dim mycc As String

    Set myItem = Item

                '这里填写你要密送的邮箱


    Debug.Print myItem.CC; myItem.To

    arrto = Split(myItem.To, ";")

    arrcc = Split(myItem.CC, ";")

Stop
    For i = 0 To UBound(arrto)

        If Not arrto(i) Like "*@163.com" Then


            strBcc = strBcc & arrto(i) & ";"

            arrto(i) = ""
        End If

    Next

    Stop
    myTo = Join(arrto, ";")

    For i = 0 To UBound(arrcc)

        If Not arrcc(i) Like "*@163.com" Then

            strBcc = strBcc & arrcc(i) & ";"
            arrcc(i) = ""

        End If

    Next
Stop
    mycc = Join(arrcc, ";")


    Set objRecip = myItem.Recipients.Add(strBcc)

    myItem.To = Trim(myTo)

    myItem.CC = Trim(mycc)
    objRecip.Type = olBCC
    If Not objRecip.Resolve Then
        strMsg = "不能解析密件抄送人邮件地址， " & _
                 "请确认是否仍然发送邮件？"
        res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
                     "不能解析密件抄送人邮件地址")
        If res = vbNo Then
            Cancel = True
        End If
    End If

    Set objRecip = Nothing


End Sub

solonely

闻启学 发表于 2015-9-10 23:56
哦哦哦  sorry 我忘记删除测试代码

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As ...

老大,还是没办法正常发送邮件,

闻启学

solonely 发表于 2015-9-15 15:53
老大,还是没办法正常发送邮件,

修改后的 请测试

1. Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
   
2.     Dim objRecip As Recipient
   
3.     Dim strMsg As String
   
4.     Dim res As Integer
   
5.     Dim strBcc As String
   
6.     On Error Resume Next
   
7.     Dim myItem As outlook.MailItem
   
8. 
   
9.     Dim arrto
   
10.     Dim arrcc
    
11. 
    
12.     Dim myTo As String
    
13. 
    
14.     Dim mycc As String
    
15. 
    
16.     Set myItem = Item
    
17. 
    
18.                 '这里填写你要密送的邮箱
    
19. 
    
20. 
    
21.     Debug.Print myItem.CC; myItem.To
    
22. 
    
23.     arrto = Split(myItem.To, ";")
    
24. 
    
25.     arrcc = Split(myItem.CC, ";")
    
26. 
    
27. 
    
28.     For i = 0 To UBound(arrto)
    
29. 
    
30.         If Not arrto(i) Like "*@163.com" Then
    
31. 
    
32. 
    
33.             strBcc = strBcc & arrto(i) & ";"
    
34. 
    
35.             arrto(i) = ""
    
36.         End If
    
37. 
    
38.     Next
    
39. 
    
40.    
    
41.     myTo = Join(arrto, ";")
    
42. 
    
43.     For i = 0 To UBound(arrcc)
    
44. 
    
45.         If Not arrcc(i) Like "*@163.com" Then
    
46. 
    
47.             strBcc = strBcc & arrcc(i) & ";"
    
48.             arrcc(i) = ""
    
49. 
    
50.         End If
    
51. 
    
52.     Next
    
53. 
    
54.     mycc = Join(arrcc, ";")
    
55. 
    
56. 
    
57.     Set objRecip = myItem.Recipients.Add(strBcc)
    
58. 
    
59.     myItem.To = Trim(myTo)
    
60. 
    
61.     myItem.CC = Trim(mycc)
    
62.     objRecip.Type = olBCC
    
63.     If Not objRecip.Resolve Then
    
64.         strMsg = "不能解析密件抄送人邮件地址， " & _
    
65.                  "请确认是否仍然发送邮件？"
    
66.         res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
    
67.                      "不能解析密件抄送人邮件地址")
    
68.         If res = vbNo Then
    
69.             Cancel = True
    
70.         End If
    
71.     End If
    
72. 
    
73.     Set objRecip = Nothing
    
74. 
    
75. 
    
76. End Sub

复制代码