讓OUTLOOK2003自動密件抄送

近日,因工作上的需要,要求把每個郵箱所發出去的郵件都要自動密件抄送到一個指定的郵件地址,用OUTLOOK可以通過規則來處理自動抄送郵件到一指定的郵件地址,但卻沒有密件抄送這一項, 在網絡上搜了一下,發現在EXCELHOME.NET論壇裏也有人提過此問題, 這問題可以通過加載宏來達到目的.事不宜遲,趕緊複製到OUTLOOK裏一

試,果然OK,有需要的朋友不妨一試.

 

打開OUTLOOK後,按ALT+F11

 

代碼如下:(此代碼轉載自club.excelhome.net)

 

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