'''''''''''''''''''''''''''''''''''''''''''' '发送Email的时候,会触发这个过程 '这段代码一定要写在发送Email的响应过程中 '''''''''''''''''''''''''''''''''''''''''''' PrivateSub Application_ItemSend(ByVal Item AsObject, Cancel AsBoolean) OnErrorResumeNext Dim message As Outlook.MailItem Set message = Item IfNot CheckAttachment(message) Then Cancel =True ExitSub EndIf End Sub
调用下面这个函数,检查是否应该有附件:
'''''''''''''''''''''''''''''''''''''''''''''' '检查标题或者正文里“附件”字样,是否可以发送附件? '''''''''''''''''''''''''''''''''''''''''''''' PrivateFunction CheckAttachment(message As Outlook.MailItem) AsBoolean CheckAttachment =True If (message.Attachments.Count =0And _ (InStr(message, "附件") >0OrInStr(message.Body, "附件") >0)) Then Dim answer As VbMsgBoxResult answer =MsgBox("没有附件, 是否继续发送?", vbYesNo + vbQuestion, "Microsoft Office Outlook") If answer = vbNo Then CheckAttachment =False Else CheckAttachment =True EndIf EndIf End Function