如果电子邮件主题行包含10位数字，如何自动将其移动到文件夹中

Question

我希望能实现这样一个功能：如果一封电子邮件的主题行中包含电话号码（即10个数字），则系统会自动将其移动到名为“Texting”的文件夹中。

用户Reidacus在此处提出了一个非常相似的问题： 使用正则表达式将传入的邮件移动到文件夹 但是我无法让它对我起作用。当电子邮件进入时，它只是停留在我的收件箱中。我非常新于VBA并且（抱歉），我不知道我在做什么。我需要在系统中安装任何特殊的内容才能使其正常工作吗？

以下是我改编的代码（请注意：在真实代码中，我有真实的电子邮件地址）。

Sub filter(Item As Outlook.MailItem)
    Dim ns As Outlook.NameSpace
    Dim MailDest As Outlook.Folder
    Set ns = Application.GetNamespace("MAPI")
    Set Reg1 = CreateObject("VBScript.RegExp")

    Reg1.Global = True
    Reg1.Pattern = "([\d][\d][\d][\d][\d][\d][\d][\d][\d][\d])"
    If Reg1.Test(Item.Subject) Then
        Set MailDest = ns.Folders("[e-mail]").Folders("Inbox").Folders("Texting")
        Item.Move MailDest
    End If
End Sub

- Cynthea Cotmen

---

你说的不工作，是指出现了任何错误吗？ - 0m3r

你有跟进链接问题中的任何测试吗？例如，放置一个MsgBox以确保脚本被调用了吗？ - YowE3K

由于您对VBA非常陌生，可能不知道您可以在规则中使用“运行脚本”选项来调用它。 - niton

@Cynthea Cotmen，你测试过我的代码了吗？有什么反馈吗？ - Shai Rado

Answer 1

为了让您的Sub Filter每次有新邮件进来时都能运行，您需要添加一个"事件监听器"，将以下代码添加到ThisOutlookSession模块中（此代码取自首页，具体链接：How do I trigger a macro to run after a new mail is received in Outlook?）。

为了使此代码生效，您必须重新启动Outlook。 ThisOutlookSession模块代码

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()

Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace

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

' get default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items

End Sub


Private Sub Items_ItemAdd(ByVal item As Object)

On Error GoTo ErrorHandler

Dim Msg As Outlook.MailItem

If TypeName(item) = "MailItem" Then
    Set Msg = item

    ' Call your custom-made Filter Sub
    Call filterNewMail_TenDig(item)
End If

ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description

Resume ProgramExit

End Sub

现在，您只需要对模块代码进行以下修改。使用ns.GetDefaultFolder(olFolderInbox)将为当前配置文件获取默认的“收件箱”文件夹（请在MSDN链接中阅读）。

子filterNewMail_TenDig代码

Sub filterNewMail_TenDig(item As Outlook.MailItem)

    Dim ns As Outlook.NameSpace
    Dim MailDest As Outlook.Folder

    Set ns = Outlook.Application.GetNamespace("MAPI")
    Set reg1 = CreateObject("VBScript.RegExp")

    With reg1
        .Global = True
        .IgnoreCase = True
        .Pattern = "\d{10,10}" ' Match any set of 10 digits
    End With

    If reg1.Test(item.Subject) Then
        Set MailDest = ns.GetDefaultFolder(olFolderInbox).Folders("Texting")
        item.Move MailDest
    End If

End Sub

- Shai Rado