outlook2007如何做自动密件抄送

在论坛里看了outlook2003规则--自动密件抄送如何做后,里面的代码应用的outlook2007不起作用,请问要修改哪里才能在2007里运行.谢

代码如下:
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 = "[email protected]" '请改成你要密送的邮件地址

    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

经反复试验,以上代码均能用于OUTLOOK2003/2007. 之前不能用于OUTLOOK2007是因为在垃圾邮件选的是项里保护级别设置高了.

能说说怎么去执行这个代码吗，我是一个OUTLOOK新手

打开OUTLOOK后按ALT+F11,将代码粘贴在右边的框里即可。

可能我默认设置有问题，按ALT+F11打开VB编辑器之后右边显示的是一片灰蒙蒙的区域，不可粘贴，请问粘贴的窗口是模块还是类模块？可能我的OFFICE宏安全性设置比较高。鉴于我这种情况，能否指点我完成？

先把OUTLOOK里宏的安全性降低，关闭OUTLOOK后重启然后再按ALT+F11, 选择ThisOutlookSession项，粘贴代码即可。

OK, 搞定了。非常感谢。

谢谢楼主分享
以后就不用一个一个的添加右键地址了！

楼主，我又回来了，我想再加一个附件提醒的功能，代码如下，请问我是加在你那段代码后面还是新建一个什么窗口，还是ThisOutlookSession吗，如何建？
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim lngres As Long

'检查邮件是否添加附件
If InStr(1, Item.Body, "附件") Or InStr(1, Item.Body, "attachment") Or InStr(1, Item.Body, "enclosed file") _
Or InStr(1, Item.Body, "Enclosed file") Or InStr(1, Item.Body, "Attachment") <> 0 Then

  If Item.Attachments.Count = 0 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

End If

'检查是否写主题
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
End Sub

请看以下代码：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim lngres As Long
'检查邮件是否添加附件
If InStr(1, Item.Body, "附件") <> 0 Then
If Item.Attachments.Count = 0 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
End If

'检查是否写主题
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 objRecip As Recipient
    Dim strMsg As String
    Dim res As Integer
    Dim strBcc As String
    On Error Resume Next

    strBcc = "[email protected]" '请改成你要密送的邮件地址

    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

[ 本帖最后由 jazzken 于 2009-11-27 13:58 编辑 ]

非常感谢！自动密送很好用

1。把专家的代码复制进Outlook的VBA编辑器的 ThisOutlookSession 里面。
2。把OUTLOOK里宏的安全性降低，允许使用宏。
3。重启Outlook2007。


Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim lngres As Long
'检查邮件是否添加附件
If InStr(1, Item.Body, "附件") <> 0 Then
If Item.Attachments.Count = 0 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
End If

'检查是否写主题
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 objRecip As Recipient
    Dim strMsg As String
    Dim res As Integer
    Dim strBcc As String
    On Error Resume Next

    strBcc = "[email protected]" '请改成你要密送的邮件地址

    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

[ 本帖最后由 efishyy 于 2010-4-20 22:28 编辑 ]

谢谢大家的分享。