Excel outlook2007如何做自动密件抄送

xiaozhenyu 2012-06-11

展开全文

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 = "postmaster@bk.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

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

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

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

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

楼主，我又回来了，我想再加一个附件提醒的功能，代码如下，请问我是加在你那段代码后面还是新建一个什么窗口，还是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 = "postmaster@bk.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

记号

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 = "123@123.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

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