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

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