需求描述

公司里面每天都会有很多邮件，三分之一都是不需要看的，Outlook的过滤功能不错，都可以处理掉。还有些邮件，根据正文或者附件做一下处理自动转发出去就行了。于是上网搜集了一些资料，写个了小程序，共享一下，以后可以参考，也希望对大家有点用处。

实现

废话少说，直接上代码吧。打开Outlook，按Alt+F11打开代码编辑器，输入下面的代码。可能有些兄弟不知道怎么入手，后面会放几个链接做参考。

Sub AutoResponseReceipt(item As MailItem)    Debug.Print ("receive an email")    Dim id As String    Dim SubjectString As String    Dim sender As String    Dim email As Outlook.MailItem    On Error GoTo Err    id = item.EntryID                   ' 先获取邮件的ID    Set email = Application.Session.GetItemFromID(id)    SubjectString = email.subject       ' 邮件主题    sender = email.SenderEmailAddress   ' 邮件的发送人地址    Debug.Print ("new email arrivaved: subject is " & SubjectString & "  sender is " & sender)    ' 校验主题，这里是对主题做过滤，不合适的直接返回不处理    Dim index As Integer    index = InStr(SubjectString, "小票")    If 0 = index Then        index = InStr(SubjectString, "receipt")        If 0 = index Then            Return        End If    End If    ' 下面这一段是我自己的一些处理逻辑，调用程序处理附件，    ' 然后将程序处理后的结果当做附件转发给另一个人    ' 获取附件并执行小票生成程序    Dim PathPrefix As String    PathPrefix = "E:\document\receipt_tool\"    Dim InputFileList As New Collection         ' 这个列表存放收到的附件    Dim OutputFileList As New Collection        ' 存放程序生成的结果    Dim AttachFile As attachment                ' 附件    For Each AttachFile In email.attachments    ' email.attachments是所有附件        Debug.Print ("attachment: " & AttachFile.FileName)        Dim InputFile As String        Dim OutputFile As String        InputFile = PathPrefix & AttachFile.FileName        OutputFile = PathPrefix & AttachFile.FileName & ".docx"        Debug.Print ("input file is " & InputFile)        Debug.Print ("output file is " & OutputFile)        AttachFile.SaveAsFile (InputFile)       ' 保存附件        Dim cmd As String        cmd = """" & PathPrefix & "receipt.exe" & """" & " " & InputFile & " " & OutputFile        Debug.Print ("command string: " & cmd)        Shell (cmd)                             ' 执行脚本，生成结果        InputFileList.Add (InputFile)        OutputFileList.Add (OutputFile)        'Kill (InputFile)   ' 这里删除的话总会把生成的文件同时删掉    Next    If OutputFileList.Count = 0 Then        Debug.Print ("no attachment")    End If    ' 转发邮件    Dim OutMail As Object    Set OutMail = Outlook.Application.CreateItem(olMailItem)    With OutMail        .To = "hnwyllmm@126.com"                ' 要转发邮件的收件人地址        .subject = "打印：" & email.subject     ' 转发邮件的主题        .Body = "帮忙打印小票，谢谢！" & Chr(10) & email.SenderEmailAddress & Chr(10) & email.SenderName ' 转发邮件的正文    End With    Dim SendAttach As String                    ' 将程序生成的结果添加到附件中    For i = 1 To OutputFileList.Count'            MsgBox (SendAttach)        SendAttach = OutputFileList(i)        OutMail.attachments.Add (SendAttach)    Next    MsgBox ("send")    OutMail.Send                                ' 发送邮件    OutMail.Delete                              ' 删除邮件，没用了Err:    ' 删除生成的文件    For i = 1 To OutputFileList.Count        Kill (OutputFileList(i))    Next    For i = 1 To InputFileList.Count        Kill (InputFileList(i))    Next    email.Delete                                ' 删除收到的邮件    ' 下面几个是释放对象，其实没有也无所谓    Set InputFileList = Nothing    Set OutputFileList = Nothing    Set OutMail = NothingEnd Sub

编辑完保存，在”开始->规则->创建规则”中添加一个过滤规则，在”如何处理该邮件”中选择运行脚本，并选择这个脚本。

参考链接

1 Visual Studio 2013 MSDN首页
2 MSDN:Outlook VBA入门教程
3 Outlook VBA教程
4 Outlook 文件夹定义

另外，在MSDN上可以直接搜索想要查看的对象。