需求描述

公司裡面每天都會有很多郵件，三分之一都是不需要看的，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 = "[email protected]"                ' 要轉發郵件的收件人地址
        .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 = Nothing

End Sub

編輯完儲存，在”開始->規則->建立規則”中新增一個過濾規則，在”如何處理該郵件”中選擇執行指令碼，並選擇這個指令碼。

參考連結

另外，在MSDN上可以直接搜尋想要檢視的物件。