規則在現有的或新創建的文件夾中歸檔郵件

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