Question

我需要根据邮件主题中的键将传入邮件移动到相关文件夹。

我开发了一个脚本，用于获取新消息主题的密钥。如何通过密钥搜索其余邮件并检索相关文件夹？

Sub CustomMailMessageRule(Item As Outlook.MailItem)
    Dim strTicket, strSubject As String 
    Dim strFolder As String
    strTicket = "None"
    strSubject = Item.Subject
    If InStr(1, strSubject, "#-") > 0 Then
        strSubject = Mid(strSubject, InStr(strSubject, "#-") + 2)
        If InStr(strSubject, " ") > 0 Then
            strTicket = Left(strSubject, InStr(strSubject, " ") - 1)
        End If
    End If

未知部分，按键搜索所有文件夹并检索相关文件夹

 strFolder = "???"

最后，通过下面的代码

将传入的消息移动到相关文件夹

    If InStr(strFolder) > 0 Then
        Item.Move Session.GetDefaultFolder(olFolderInbox).folders(strFolder)

    MsgBox "Your New Message has been moved to related folder "  
End Sub

我是VBA的新人。

Answer 1

按主题递归搜索文件夹。

Option Explicit

Sub CustomMailMessageRule(Item As mailItem)

    Dim strSubject As String
    Dim strDynamic As String
    Dim strFilter As String

    Dim originFolder As Folder
    Dim startFolder As Folder
    Dim uPrompt As String

    strSubject = Item.subject

    Set startFolder = Session.GetDefaultFolder(olFolderInbox)

    ' To reference any inbox not specifically the default inbox
    'Set startFolder = Session.folders("email address").folders("Inbox")

    Set originFolder = startFolder

    ' For testing the mail subject is "This is a test"
    If InStr(1, strSubject, "This is") > 0 Then

        ' For testing the dynamically determined key is "a test"
        strDynamic = "a test"

        strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & strDynamic & "%'"
        Debug.Print strFilter

        ' Advanced search requires "Scope" to be specified so it appears
        '  not easy/possible to process every subfolder in the way described here
        ' https://stackoverflow.com/questions/43638711/outlook-macro-advanced-search

        '  This recursively processes every subfolder
        processFolder originFolder, startFolder, strFilter, Item

        uPrompt = "Mail with " & strDynamic & " in subject not found in subfolders of " & startFolder.Name
        Debug.Print uPrompt
        MsgBox uPrompt

    End If

ExitRoutine:
    Set startFolder = Nothing

End Sub

Private Sub processFolder(ByVal originFolder As Folder, ByVal oParent As Folder, strFilter As String, oIncomingMail As mailItem)

    Dim oFolder As Folder
    Dim oObj As Object
    Dim filteredItems As items

    Dim uResp As VbMsgBoxResult

    Debug.Print oParent

    If originFolder.EntryID <> oParent.EntryID Then

        ' This narrows the search.
        ' https://stackoverflow.com/questions/21549938/vba-search-in-outlook
        Set filteredItems = oParent.items.Restrict(strFilter)

        If filteredItems.count > 0 Then

            Debug.Print oParent
            Debug.Print "Mail found in " & oParent.Name

            uResp = MsgBox(Prompt:="Move Message to folder: " & oParent.Name & "?", _
              Buttons:=vbYesNoCancel)

            If uResp = vbYes Then
                oIncomingMail.move oParent
                End
            End If

            If uResp = vbCancel Then End

        End If

    End If

    If (oParent.folders.count > 0) Then
        For Each oFolder In oParent.folders
            processFolder originFolder, oFolder, strFilter, oIncomingMail
        Next
    End If

End Sub

按主题键搜索文件夹

1 个答案: