regex - Recognize pattern for categorizing mails then move mail to folders that are created if needed
问题描述
I developed a email-filtering VBA code, so I can recognize the pattern [ABC] for categorizing mails.
I expect incoming mails to be moved to folders and categorized.
The folders are to be created if needed.
Target :
extract words within [this Bracket], and specific code such as CMX , INC
Subject :
[ABC]
--> create inbox folderABC
Subject :
[CMX]
--> create inbox folderABC
Subject :
CMX
--> create inbox folderCMX
Subject :
INC000000156156
--> create inbox folderINC
and sub-folderINC000000156156
The code does not create folders, especially when I delete the folder with mails.
Private Sub Application_NewMail()
Dim olFld As Outlook.MAPIFolder
Set olFld = Outlook.Session.GetDefaultFolder(olFolderInbox)
olFld.Items.Sort "[ReceivedTime]", False
Dim olMail As Outlook.MailItem
Set olMail = olFld.Items.GetFirst
MyNiftyFilter olMail
End Sub
Private Sub MyNiftyFilter(Item As Outlook.MailItem)
Debug.Print Item
Debug.Print Item.Subject
Dim Matches As Variant
Dim RegExp As New VBScript_RegExp_55.RegExp
Dim Pattern As String
Dim Email_Subject As String
Pattern = "\[(.*?)\]"
Email_Subject = Item.Subject
With RegExp
.Global = False
.Pattern = Pattern
.IgnoreCase = True
Set Matches = .Execute(Email_Subject)
End With
Dim olFld As Outlook.MAPIFolder
Set olFld = Outlook.Session.GetDefaultFolder(olFolderInbox)
Dim SubFolder As Outlook.MAPIFolder
If Matches.Count > 0 Then
Debug.Print Matches(0)
Debug.Print Matches(0).SubMatches(0)
Set oloUtlook = CreateObject("Outlook.Application")
Set ns = oloUtlook.GetNamespace("MAPI")
Set itm = ns.GetDefaultFolder(olFolderInbox)
On Error Resume Next
Set SubFolder = itm.Folders.Item(Matches(0).SubMatches(0))
If SubFolder Is Nothing Then
SubFolder = itm.Folders.Add(Matches(0).SubMatches(0))
End If
Item.Move SubFolder
End If
Set RegExp = Nothing
Set Matches = Nothing
Set Item = Nothing
End Sub
解决方案
尝试这样的事情
Private Sub Application_NewMail()
Dim olFld As Outlook.MAPIFolder
Set olFld = Outlook.Session.GetDefaultFolder(olFolderInbox)
olFld.Items.Sort "[ReceivedTime]", False
Dim olMail As Outlook.MailItem
Set olMail = olFld.Items.GetFirst
MyNiftyFilter olMail
End Sub
Private Sub MyNiftyFilter(Item As Outlook.MailItem)
Debug.Print Item
Debug.Print Item.Subject
Dim Matches As Variant
Dim RegExp As New VBScript_RegExp_55.RegExp
Dim Pattern As String
Dim Email_Subject As String
Pattern = "(([\w-\s]*)\s*)"
Email_Subject = Item.Subject
With RegExp
.Global = False
.Pattern = Pattern
.IgnoreCase = True
Set Matches = .Execute(Email_Subject)
End With
If Matches.Count > 0 Then
Debug.Print Matches(0) ' Print on Immediate Window
End If
Set RegExp = Nothing
Set Matches = Nothing
Set Item = Nothing
End Sub
对于正则表达式使用 \[(.*?)\]
*demo
https://regex101.com/r/U3bjOf/1
https://regex101.com/r/U3bjOf/2
If Matches.Count > 0 Then
Debug.Print Matches(0) ' full match [ABC]
Debug.Print Matches(0).submatches(0) ' submatch ABC
End If
像这样创建子文件夹使用功能
'// Function - Check folder Exist
Private Function FolderExists(Inbox As MAPIFolder, FolderName As String)
Dim Sub_Folder As MAPIFolder
On Error GoTo Exit_Err
Set Sub_Folder = Inbox.Folders(FolderName)
FolderExists = True
Exit Function
Exit_Err:
FolderExists = False
End Function
然后调用它
Dim olFld As Outlook.MAPIFolder
Set olFld = Outlook.Session.GetDefaultFolder(olFolderInbox)
Dim SubFolder As Outlook.MAPIFolder
Dim FolderName As String
If Matches.Count > 0 Then
Debug.Print Matches(0) ' full match [ABC]
Debug.Print Matches(0).submatches(0) ' submatch ABC
FolderName = Matches(0).submatches(0)
'// Check if folder exist else create one
If FolderExists(Inbox, FolderName) = True Then
Set SubFolder = Inbox.Folders(FolderName)
Else
Set SubFolder = Inbox.Folders.Add(FolderName)
End If
Item.Move SubFolder
End If
推荐阅读
- php - 从下拉菜单中获取输入到 php
- javascript - 从导航栏过滤反应组件
- maven - 停止记录 Gatling 请求
- reactjs - 在应用程序中使用 shopify api 创建客户
- android - TabLayout 选定的文本颜色同时显示在两个选项卡中
- datetime - 如何在时区为 IST 的 presto 中将纪元时间转换为人类可读的日期
- javascript - 从 Wix 到 Zapier 的 Webhook
- python - 在 Python 中不工作的摩尔斯电码解密器
- c++ - 异常基础知识:为什么while循环会变成无限循环?
- ssh - 在 MobaXterm 中打开会话时如何自动启动隧道?