在现有或新创建的文件夹中归档邮件的规则

Question

我是 VBA 新手，需要您的帮助来制定一个搜索电子邮件主题的规则，如果在主题中找到特定字符串“LSC_”，例如：LSC_IND_TATA 并且默认命名约定是 LSC_XXX_XXX 或 [LSC_XXX_XXX]，那么邮件被移动到指定的子文件夹或 LSC 新创建的子文件夹。

所以outlook文件夹结构如下图所示

LSC

-LSC_IND_TATA

-LSC_IND_TATA_02

-LSC_xxx_xxx

Function CheckForFolder(strFolder As String) As Boolean

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0

If Not FolderToCheck Is Nothing Then
    CheckForFolder = True
End If

ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

Set CreateSubFolder = olInbox.Folders.Add(strFolder)

ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function SearchAndMove(lookFor As String)

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Dim myItem As Object
Dim MyFolder As Outlook.MAPIFolder
Dim lookIn As String
Dim newName As String
Dim location As Integer

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
 For Each myItem In olInbox.Items
 lookIn = myItem.Subject
 If InStr(lookIn, lookFor) Then
     location = InStr(lookIn, lookFor)
             newName = Mid(lookIn, location)
        If CheckForFolder(newName) = False Then
            Set MyFolder = CreateSubFolder(newName)
            myItem.Move MyFolder
                Else
            Set MyFolder = olInbox.Folders(newName)
            myItem.Move MyFolder
        End If
    End If
Next myItem
End Function

Sub myMacro()
Dim str As String
str = "LSC_"
SearchAndMove (str)
End Sub

Answer 1

Function CheckForFolder(strFolder As String) As Boolean

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder

Dim olInbox_Target As Outlook.MAPIFolder ' <---

Dim FolderToCheck As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")

Set olInbox_Target = olNS.GetDefaultFolder(olFolderInbox).Folders("LSC") ' <---

On Error Resume Next
Set FolderToCheck = olInbox_Target.Folders(strFolder) ' <---
On Error GoTo 0

If Not FolderToCheck Is Nothing Then
    CheckForFolder = True
End If

ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder

Dim olInbox_Target As Outlook.MAPIFolder ' <---

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")

Set olInbox_Target = olNS.GetDefaultFolder(olFolderInbox).Folders("LSC") ' <---

Set CreateSubFolder = olInbox_Target.Folders.Add(strFolder)

ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function SearchAndMove(lookFor As String, myitem As mailItem)

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
'Dim olInbox As Outlook.MAPIFolder

Dim olInbox_Target As Outlook.MAPIFolder ' <---

Dim FolderToCheck As Outlook.MAPIFolder
'Dim myitem As Object
Dim MyFolder As Outlook.MAPIFolder
Dim lookIn As String
Dim newName As String
Dim location As Integer

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")

'Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set olInbox_Target = olNS.GetDefaultFolder(olFolderInbox).Folders("LSC") ' <---

'For Each myItem In olInbox.Items

    lookIn = myitem.Subject

    If InStr(lookIn, lookFor) Then

        location = InStr(lookIn, lookFor)
        newName = Mid(lookIn, location)

        If Right(newName, 1) = "]" Then
            newName = Left(newName, Len(newName) - 1)
        End If

        If CheckForFolder(newName) = False Then
            Set MyFolder = CreateSubFolder(newName)
            myitem.Move MyFolder
        Else
            Set MyFolder = olInbox_Target.Folders(newName)
            myitem.Move MyFolder
        End If

    End If

'Next myItem

End Function

' Choose this in Run a Script
Sub myMacro(itm As mailItem)
Dim str As String
str = "LSC_"
SearchAndMove str, itm
End Sub

' To test
' Manually select an email with an appropriate subject
Sub myMacroTest()
Dim itm As mailItem
Set itm = ActiveExplorer.Selection(1)
myMacro itm
End Sub