如何将触发文件夹创建的邮件插入该文件夹？

Question

我想将新收到的邮件分配到新文件夹。

已创建文件夹，但不是立即插入邮件。

如何创建文件夹并将新邮件移动到新文件夹？

If Matches.Count > 0 Then
    Dim MatchFile As String
    Dim MatchSubFile As String
    MatchFile = Matches(0)
    MatchSubFile = Matches(0).SubMatches(0)
    Dim TargetFolder As String
    If Len(MatchFile) > 0 Then
        TargetFolder = MatchFile
    End If

    If InStr(MatchFile, "[") > 0 Then
        TargetFolder = MatchSubFile
    End If

    Set oloUtlook = CreateObject("Outlook.Application")
    Set ns = oloUtlook.GetNamespace("MAPI")
    Set itm = ns.GetDefaultFolder(olFolderInbox)
    On Error Resume Next
    Set SubFolder = itm.Folders.Item(TargetFolder)
    If SubFolder Is Nothing Then
        SubFolder = itm.Folders.Add(TargetFolder)
        Item.Move SubFolder
    End If
    Item.Move SubFolder
End If

Answer 1

考虑On Error GoTo 0为强制性，并且在On Error Resume Next之后尽可能少的行。

已添加文件夹，但绕过了意外错误。将On Error Resume Next用于预期的错误，否则将无济于事。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration


Private Sub test()
    MyNiftyFilter ActiveInspector.CurrentItem
End Sub


Private Sub MyNiftyFilter(item As MailItem)

    Debug.Print item.Subject

    Dim inboxFldr As folder
    Dim SubFolder As folder

    Dim Matches As Variant
    Dim RegExp As New VBScript_RegExp_55.RegExp

    Dim MatchFile As String
    Dim MatchSubFile As String

    Dim Pattern As String
    Dim Email_Subject As String

    Dim targetFolder As String

    Pattern = "\[(.*?)\]"
    Email_Subject = item.Subject

    With RegExp
        .Global = False
        .Pattern = Pattern
        .IgnoreCase = True
        Set Matches = .Execute(Email_Subject)
    End With

    If Matches.Count > 0 Then

        MatchFile = Matches(0)
        MatchSubFile = Matches(0).submatches(0)

        If Len(MatchFile) > 0 Then
            targetFolder = MatchFile
        End If

        If InStr(MatchFile, "[") > 0 Then
            targetFolder = MatchSubFile
        End If

        Set inboxFldr = Session.GetDefaultFolder(olFolderInbox)

        ' Rare valid use
        On Error Resume Next

        'Bypass error when SubFolder does not exist
        Set SubFolder = inboxFldr.folders.item(targetFolder)

        ' Use as soon as the purpose of the error bypass is done
        '  to return to normal error handling
        On Error GoTo 0 ' Consider this mandatory after On Error Resume Next

        If SubFolder Is Nothing Then

            ' Unexpected error bypassed due to
            '  previous poor error handling technique
            'SubFolder = inboxFldr.folders.Add(TargetFolder)

            Set SubFolder = inboxFldr.folders.Add(targetFolder)

        End If

        Item.Move SubFolder

    End If

End Sub