outlook邮件发送时自动检查附件，以及延时发送

leucine · 发表于 2011-8-18 14:31

代码如下，进入outlook后，按alt+f11，在ThisOutlookSession里面贴入如下代码，记得把outlook的宏安全性调整为“低”哦。

win7 ultimate + outlook2010通过，理论上outlook2007也可以，但2003不确定，希望大家多测试。做了有限次的测试，也不能保证没有bug，大家多提意见。

实现功能：
1、按发送后，如果正文或标题里包含“attach”、“附件”，但邮件却没有附件，将弹出提示窗口。支持检测多个关键词，自己修改代码。

2、可以延时发送邮件，延时时间以秒计算。（outlook的规则里面的延时时间最低为1分钟），如果不需要该功能，可在代码里关闭。可以设定重要性为高的邮件是否也延时发送。

延时发送有两种实现方式，可以都尝试一下，建议不了解vba的兄弟还是采用第一种延时发送的方法。：
a、（默认的方式）点击发送后，弹出一个对话框，如果点击ok就马上发送，如果点击cancel就不发送，如果什么都不动，那么10秒钟后自动发送（可自行设置时间）。
b、点击发送后，邮件保存在发件箱里，10秒钟后自动发送。该方法采用mailItem.DeferredDeliverTime属性，但由于本人vba技术有限，因此，如果采用这一方法，延时发送的时间很难控制在10秒，请高手解决。

该vba的原文来自网上，感谢原作者，为了阅读方便，我删掉了原作者的注释信息，请原谅。

Private Declare Function MsgBoxEx Lib "user32" Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) As Long
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If TypeName(Item) <> "MailItem" Then Exit Sub
Dim intRes As Integer
Dim strMsg As String
Dim strThismsg As String
Dim intOldmsgstart As Integer
Dim sSearchStrings(2) As String
Dim bFoundSearchstring As Boolean
Dim i As Integer ' loop var for FOR-NEXT-loop
Dim intDeferStyle As Integer
Dim intDeferTime As Integer
Dim intMailImportance As Integer
Dim bDeferImportance As Boolean
bFoundSearchstring = False
intMailImportance = Item.Importance
'设定附件提醒的相关参数
sSearchStrings(0) = "attach" '正文或标题包含的关键字，当找到这些关键字时，就认定邮件应该带附件
sSearchStrings(1) = "enclose" '可以设定多个关键字，但记得在“Dim sSearchStrings(2) As String”语句中更改数组上限
sSearchStrings(2) = "附件"
'延时发送相关参数，可以更改
intDeferStyle = 1 '延时发送的模式，0=不延时发送，1=跳出倒计时对话框，2=采用outlook自带的延时发送属性DeferredDeliveryTime
intDeferTime = 10 '延时发送的时间，单位秒
bDeferImportance = False '重要性为高的邮件是否也延时发送，0=重要性高的邮件不延时，1=重要性高的邮件也延时
If bDeferImportance Then
intMailImportance = 1
End If
'检查附件
intOldmsgstart = InStr(Item.Body, "-----Original Message-----")
If intOldmsgstart = 0 Then
strThismsg = Item.Body + " " + Item.Subject
Else
strThismsg = Left(Item.Body, intOldmsgstart) + " " + Item.Subject
End If
For i = LBound(sSearchStrings) To UBound(sSearchStrings)
If InStr(LCase(strThismsg), sSearchStrings(i)) > 0 Then
bFoundSearchstring = True
Exit For
End If
Next i
If bFoundSearchstring Then
If Item.Attachments.Count = 0 Then
strMsg = "Attachment Checker:" & Chr(13) & Chr(10) & "邮件内容提到了附件，但没有找到任何附件！" & Chr(13) & Chr(10) & "确定不添加附件吗？"
intRes = MsgBox(strMsg, vbYesNo + vbDefaultButton2 + vbExclamation, "You forgot the attachment!")
If intRes = vbNo Then
' cancel send
Cancel = True
End If
End If
End If
'延时发送
If intDeferStyle = 1 And intMailImportance <> 2 Then
'弹出倒计时对话框的方式，实现延时发送
strMsg = intDeferTime & "秒后发送邮件" & Chr(13) & Chr(10) & "马上发送请点确定，后悔请点取消，否则耐心等待"
intRes = MsgBoxEx(0, strMsg, "延时发送邮件", vbYesNo + vbInformation, 1, intDeferTime * 1000)
If intRes = vbNo Then
Cancel = True
End If
ElseIf intDeferStyle = 2 And intMailImportance <> 2 Then
'采用outlook自带的DeferredDeliveryTime属性实现延时发送，有些小问题，很难控制10秒后准确发送，请高手解决，菜鸟可以用第一种延时发送方式
Item.DeferredDeliveryTime = DateAdd("s", intDeferTime, Now)
End If
End Sub

复制代码

dsd999 · 发表于 2011-8-18 15:00

那段代码在2003里没问题。
你的操作系统是什么？

2003里没有msgboxex函数。

dsd999 · 发表于 2011-8-18 14:52

CreateObject("Wscript.Shell").Popup "本窗口将在三秒钟后自动关闭……", 1, "MsgBox", 64

试试这个

leucine · 发表于 2011-8-18 14:56

dsd999 发表于 2011-8-18 14:52
CreateObject("Wscript.Shell").Popup "本窗口将在三秒钟后自动关闭……", 1, "MsgBox", 64

试试这个

呵呵，已经试过了，但不知道为什么，在我的outlook2010里面，用Wscript的方法，弹出的窗口没法自动关闭。我也是在excel vba里面找了半天之后，终于发现msgboxex这个函数能够自动关闭。

leucine · 发表于 2011-8-18 15:06

dsd999 发表于 2011-8-18 15:00
那段代码在2003里没问题。
你的操作系统是什么？

我是win7 ultimate+outlook2010.

可能2003里面把MsgBoxEx改为MessageBoxTimeout吧。并且把第一行改为：
Private Declare Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long, ByVal wlange As Long, ByVal dwTimeout As Long) As Long

可以试试这样行不行。

我是在这个帖子里面看到的这个函数：http://club.excelhome.net/thread-590980-1-1.html

但在我的系统上用MessageBoxTimeout提示找不到函数，后来才换成MsgBoxEx的。

mzp320123 · 发表于 2012-12-13 08:31

我的2010不管用吗~~

开心萝卜惠州 · 发表于 2013-1-2 15:01

2010的好像没有反应，直接发出去了

xiaozheng0622 · 发表于 2015-11-26 21:31

我勒个擦~~太高级了

		自动登录	找回密码
密码			免费注册

[分享] outlook邮件发送时自动检查附件，以及延时发送

评分