一个Outlook宏写的小程序,献给象我一样粗心大意的人
最近经常有这样的事情出现:Email已经发出去了,却发现附件没有加上,于是再补上一个Email。
不得已写了下面这个小程序,可以用在Outlook上面。在Email发送的时候,他会检查标题和正文里面有没有“附件”两个字,如果有这两个字,却又没有附件,就会出现提示。
最近用了这个东西,还是不错的,预防了不少事故的发生。谨在此献给象我一样粗心的人,希望大家喜欢。
代码如下:
调用下面这个函数,检查是否应该有附件:
要运行这个宏,可能要改变Outlook的宏安全设置。
不得已写了下面这个小程序,可以用在Outlook上面。在Email发送的时候,他会检查标题和正文里面有没有“附件”两个字,如果有这两个字,却又没有附件,就会出现提示。
最近用了这个东西,还是不错的,预防了不少事故的发生。谨在此献给象我一样粗心的人,希望大家喜欢。
代码如下:
''''''''''''''''''''''''''''''''''''''''''''
'发送Email的时候,会触发这个过程
'这段代码一定要写在发送Email的响应过程中
''''''''''''''''''''''''''''''''''''''''''''
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
Dim message As Outlook.MailItem
Set message = Item
If Not CheckAttachment(message) Then
Cancel = True
Exit Sub
End If
End Sub
'发送Email的时候,会触发这个过程
'这段代码一定要写在发送Email的响应过程中
''''''''''''''''''''''''''''''''''''''''''''
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
Dim message As Outlook.MailItem
Set message = Item
If Not CheckAttachment(message) Then
Cancel = True
Exit Sub
End If
End Sub
调用下面这个函数,检查是否应该有附件:
''''''''''''''''''''''''''''''''''''''''''''''
'检查标题或者正文里“附件”字样,是否可以发送附件?
''''''''''''''''''''''''''''''''''''''''''''''
Private Function CheckAttachment(message As Outlook.MailItem) As Boolean
CheckAttachment = True
If (message.Attachments.Count = 0 And _
(InStr(message, "附件") > 0 Or InStr(message.Body, "附件") > 0)) Then
Dim answer As VbMsgBoxResult
answer = MsgBox("没有附件, 是否继续发送?", vbYesNo + vbQuestion, "Microsoft Office Outlook")
If answer = vbNo Then
CheckAttachment = False
Else
CheckAttachment = True
End If
End If
End Function
'检查标题或者正文里“附件”字样,是否可以发送附件?
''''''''''''''''''''''''''''''''''''''''''''''
Private Function CheckAttachment(message As Outlook.MailItem) As Boolean
CheckAttachment = True
If (message.Attachments.Count = 0 And _
(InStr(message, "附件") > 0 Or InStr(message.Body, "附件") > 0)) Then
Dim answer As VbMsgBoxResult
answer = MsgBox("没有附件, 是否继续发送?", vbYesNo + vbQuestion, "Microsoft Office Outlook")
If answer = vbNo Then
CheckAttachment = False
Else
CheckAttachment = True
End If
End If
End Function
要运行这个宏,可能要改变Outlook的宏安全设置。