OUTLOOK有条件的密送功能

solonely

以下的代码是以前的一位论坛大大写的,在OUTLOOK中自动密送给指定的邮箱.

想请各位高手帮忙修改一下条件,在收件人或抄送人中如果有不包含"@126.com"的邮箱地址,才自动密送给指定的邮箱



在outlook中alt+F11打开vba，把下面的内容放到"ThisOutlookSession"中就可以实现每次写完邮件点“发送”的时候自动添加密送地址。


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

    strBcc = "XXXXXXXX@163.com"               '这里填写你要密送的邮箱

    Set objRecip = Item.Recipients.Add(strBcc)
    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

有人可以帮忙吗?

solonely

每天一顶,顶到高手出现为止呀

闻启学

solonely 发表于 2014-1-14 09:29
每天一顶,顶到高手出现为止呀

联系我  让我玩玩

solonely

闻启学 发表于 2014-1-14 14:19
联系我  让我玩玩

就是上面的代码,帮我加个条件就可以了呀

solonely

求大神出现啊

闻启学

solonely 发表于 2014-1-24 14:32
求大神出现啊

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. Stop
    
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.     Stop
    
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. Stop
    
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.    
    
63.     Stop
    
64.     objRecip.Type = olBCC
    
65.     If Not objRecip.Resolve Then
    
66.         strMsg = "不能解析密件抄送人邮件地址， " & _
    
67.                  "请确认是否仍然发送邮件？"
    
68.         res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
    
69.                      "不能解析密件抄送人邮件地址")
    
70.         If res = vbNo Then
    
71.             Cancel = True
    
72.         End If
    
73.     End If
    
74. 
    
75.     Set objRecip = Nothing
    
76. 
    
77. 
    
78. End Sub
    

复制代码

测试一下

solonely

闻启学 发表于 2014-1-24 18:03
测试一下

到第27号就停止了,邮件发不出去

solonely

闻启学 发表于 2014-1-24 18:03
测试一下

大哥,能帮忙再修改一下吗?

闻启学

solonely 发表于 2015-9-9 17:56
大哥,能帮忙再修改一下吗?

给个附件我 看看