求一个邮件延迟发送的方法，顺便分享一个个人认为不错的检查附件的vba

leucine · 发表于 2011-8-18 11:16

我用的outlook2010，outlook规则里面的延迟发送邮件，最小间隔是1分钟，这个有点长，有时候碰到比较急的邮件，要等1分钟才发出去实在是太急人了。个人认为10秒的延迟发送也就足够了，肯定来得及后悔。所以想用vba做一个。

看了之前的帖子，试着用这个语句来延迟发送，在当前时间基础上延迟10秒：
item.DeferredDeliveryTime=DateAdd("s",10,now())

但发现实际效果不如人意，这个DeferredDeliveryTime总是自动取整的分钟数。比如现在是10:50:20，那么DateAdd("s",10,now)之后应该是10:50:30，但实际上，如果msgbox item.DeferredDeliveryTime电话，会发现这个DeferredDeliveryTime被设定成10:51:00，后面这个秒数总是自动取0。

求高手解决。另外我想的另外一个方法，直接在写完邮件点击发送按钮之后，出现一个10秒倒计时的对话框，如果倒计时为0就开始发送，如果中途点击了“取消”，就取消发送。不过，用msgbox好像不能显示倒计时，也不能自动关闭，我的vba知识很少，不知道该用什么方法，求助。

另外，分享一个个人觉得比较好的检查附件的vba，从网上查到的，感谢原作者。这个vba的优点在于：可以自己设定检查的关键字。记得把outlook的宏安全设定为“低”：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If TypeName(Item) <> "MailItem" Then Exit Sub
' VBA program for Outlook, (c) Dan Evans. dan at danevans.co.uk
' Will check if your outgoing email mentions an attachment, but you've
' forgotten to attach it
' v1.03b of 29/7/05 - Modified by Leonard Slingerland (leonard at slingerland.biz) to have array of words rather than just one
' v1.03 of 10/8/04 - Modified to search through subject line as well as message body
' v1.02 of 16/10/02 - No change to code, but tested works with Outlook 2002 as well as Outlook 2000
' v1.01 of 23/9/01 - OK for "Attach" as well as "attach"
' v1.00 of 21/9/01 - Initial working version
Dim intRes As Integer
Dim strMsg As String
Dim strThismsg As String
Dim intOldmsgstart As Integer
' ADDED BY LS >>>
' - Does not search for "Attach", but for all strings in an array that is defined here
Dim sSearchStrings(2) As String
Dim bFoundSearchstring As Boolean
Dim i As Integer ' loop var for FOR-NEXT-loop
bFoundSearchstring = False
sSearchStrings(0) = "attach"
sSearchStrings(1) = "enclose"
sSearchStrings(2) = "附件"
' ADDED BY LS <<<
intOldmsgstart = InStr(Item.Body, "-----Original Message-----")
' intOldmsgstart is the location of where old/re/fwd msg starts. Will be 0 if new msg
If intOldmsgstart = 0 Then
strThismsg = Item.Body + " " + Item.Subject
Else
strThismsg = Left(Item.Body, intOldmsgstart) + " " + Item.Subject
End If
' The above if/then/else will set strThismsg to be the text of this message only,
' excluding old/fwd/re msg
' IE if the original included message is mentioning an attachment, ignore that
' Also includes the subject line at the end of the strThismsg string
' ADDED BY LS >>>
For i = LBound(sSearchStrings) To UBound(sSearchStrings)
If InStr(LCase(strThismsg), sSearchStrings(i)) > 0 Then
bFoundSearchstring = True
Exit For
End If
Next i
' ADDED BY LS <<<
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
End Sub

复制代码

leucine · 发表于 2011-8-18 11:18

感觉上面的代码有些乱，因此去掉注释之后，再发一遍：

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
bFoundSearchstring = False
sSearchStrings(0) = "attach"
sSearchStrings(1) = "enclose"
sSearchStrings(2) = "附件"
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 = True
End If
End If
End If
End Sub

复制代码

dsd999 · 发表于 2011-8-18 11:37

谢谢分享，待会在2003试试。

就是有个问题，很急的邮件为什么不立即发送呢，为什么还要延迟？

leucine · 发表于 2011-8-18 12:53

dsd999 发表于 2011-8-18 11:37
谢谢分享，待会在2003试试。

就是有个问题，很急的邮件为什么不立即发送呢，为什么还要延迟？

多谢版主了。很急的邮件，延迟10秒发送还是可以的，只不过延迟1分钟就有点久了。所以，用outlook自带的规则时，延迟时间最短1分钟，就不是很合适。

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

很急的邮件为什么不立即发送呢？

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

本帖最后由 leucine 于 2011-8-18 14:34 编辑

是这样，如果在outlook规则里面设置了“所有邮件延迟1分钟发送”，那么就算很急的邮件，点击发送后，它也会等1分钟才发送。如果每次要取消这个规则，再发送，就太麻烦了。

刚刚在excel vba区看到一个函数msgboxex，于是自己动手，顺利解决了问题，贴出来跟大家分享。

为了便于搜索，就新开了一个主题：

http://club.excelhome.net/thread-754442-1-1.html

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

其实我还是不明白急邮件为什么不立刻发送？

你是用VBA创建邮件？

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

dsd999 发表于 2011-8-18 14:55
其实我还是不明白急邮件为什么不立刻发送？

你是用VBA创建邮件？

是这样：为了留一个“后悔药”，所以我需要设定邮件延迟一段时间发送，就像Gmail里面一样。在这段时间里面，如果突然觉得邮件不该发，或者还有需要补充的，就可以取消发送，进行更改。

以前我采用的方法是，直接使用outlook自动规则里面的延迟发送，这个规则里面最小的延迟时间是1分钟，没法用更短的时间。

这样，所有的邮件点击发送之后，都会延迟1分钟发送，1分钟之内如果后悔了，就可以不发送，同时我也在规则里面也设定了“重要性为高”的邮件就不延迟发送，确保有些邮件能够马上发送。

但实际使用中，有些重要邮件需要马上发送的，我却忘了更改重要性为高。这样导致这些邮件都是延迟1分钟发送了。

我希望模仿Gmail的方式，所有邮件都延迟发送，但延迟时间仅10～20秒。

不是我不想立刻发送这些重要邮件啊，问题是，每次重要邮件如果要马上发送的话，都要设置成重要性高，或者取消自动规则，是件很麻烦的事。

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

这次说的很详细，明白了。看来你每天要发很多封邮件。

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

[求助] 求一个邮件延迟发送的方法，顺便分享一个个人认为不错的检查附件的vba