Question

我想这样做，如果电子邮件中包含主题行中的电话号码（因此10位数字），系统会自动将其移动到名为“发短信”的文件夹中。

用户Reidacus在这里问了一个非常相似的问题： Move incoming mail to folders with RegEx in a rule

但我无法让它为我工作。当电子邮件进来时它就在我的收件箱中。我很新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("firstname.lastname@email.ca").Folders("Inbox").Folders("Texting")
        Item.Move MailDest
    End If
End Sub

Answer 1

为了让您的Sub Filter每次都有新的电子邮件投放，您需要添加“事件监听器”，方法是将以下代码添加到 ThisOutlookSession 模块（此代码取自家中，此处为SO：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 link）。

Sub 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

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

1 个答案: