件名のキーでフォルダを検索

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