☰

Outlook 在电子邮件上运行 VBA 脚本，根据主题中的 6 位数字移动到文件夹

tag-icon • tag-icon email microsoft-outlook vba
Outlook 在电子邮件上运行 VBA 脚本，根据主题中的 6 位数字移动到文件夹

我们公司为项目使用一个 6 位数字。我尝试创建一个脚本，该脚本将在电子邮件主题中搜索这个 6 位数字，然后找到以这个 6 位数字开头的子文件夹，并将电子邮件移动到该文件夹​​。

在搜索如何执行此操作时，我窃取了一些代码并得出了下面的内容。我输入了一些 MsgBox 命令，试图弄清楚事情是否在一路运行。但是当我运行代码（规则>管理规则和警报>立即运行规则）时，我没有收到错误，也没有收到任何 MsgBox。有人对我可能做错的事情有什么想法/评论吗？

Sub filterbyprojectnumber(Item As Outlook.MailItem)
    Dim nsOutlook As Outlook.NameSpace
    Dim MailDest As Outlook.Folder
    Set nsOutlook = Application.GetNamespace("MAPI")
    Set RegExp = CreateObject("VBScript.RegExp")
    MsgBox Item.Subject
    RegExp.Global = True
    RegExp.Pattern = "([^\d]|^)\d{6}([^\d]|$)"
    If RegExp.Test(Item.Subject) Then
        MsgBox Item.Subject
        MailDest = FindInFolders(Application.Session.Folders, RegExp.Test(Item.Subject))
        MsgBox MailDest
        Item.Move MailDest
    End If
End Sub

Function FindInFolders(TheFolders As Outlook.Folder, Name As String)
  Dim SubFolder As Outlook.MAPIFolder

  On Error Resume Next

  Set FindInFolders = Nothing

  For Each SubFolder In TheFolders
    If LCase(SubFolder.Name) Like LCase(Name) Then
      Set FindInFolders = SubFolder
      Exit For
    Else
      Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
      If Not FindInFolders Is Nothing Then Exit For
    End If
  Next
End Function

答案1

递归代码用于处理所有文件夹。

可以强制代码从中间某处返回一个文件夹。可能有更好的方法。

Option Explicit

Private Sub test()
    ' First open a mailitem
    ' F8 from here to step through
    filterByProjectNumber ActiveInspector.CurrentItem
End Sub

Sub filterByProjectNumber(Item As MailItem)

    Dim MailDest As Folder
    Dim RegExp As RegExp
    Dim objMatch As MatchCollection

    Dim srchName As String
    Dim fndFolder As Folder

    ' Tick the reference to Microsoft VBScript Regular Expressions
    Set RegExp = CreateObject("VBScript.RegExp")
    Debug.Print "Subject of currently open item: " & Item.Subject

    RegExp.Global = True
    RegExp.Pattern = "([^\d]|^)\d{6}([^\d]|$)"

    If RegExp.test(Item.Subject) Then

        Debug.Print "Subject found: " & Item.Subject

        Set objMatch = RegExp.Execute(Item.Subject)
        srchName = (objMatch(0).Value)

        ' In these test subjects
        '   123456 test
        '   234567
        '   test 234567 test
        '  leading and/or trailing space had to be removed

        Debug.Print "-srchName-: " & "-" & srchName & "-"
        srchName = Trim(objMatch(0).Value)
        Debug.Print "-srchName-:  " & "-" & srchName & "-"

        ' MailDest will be Nothing
        '  if there is no way to exit
        '  when "fndFolder" is found
        Set MailDest = findInFolders(Session.Folders, srchName, fndFolder)

        If Not fndFolder Is Nothing Then
            Debug.Print fndFolder.Name
            Item.Move fndFolder
        Else
            Debug.Print "No matching folder found."
        End If

    Else
        Debug.Print "No regex match"

    End If

End Sub

Function findInFolders(TheFolders As Folders, sName As String, fFolder As Folder)

    Dim subFolder As Folder

    Set findInFolders = Nothing

    For Each subFolder In TheFolders

        'Debug.Print "subFolder: " & subFolder
        'Debug.Print "    sName: " & sName

        If InStr(LCase(subFolder.Name), LCase(sName)) Then

            Debug.Print "*** subFolder: " & subFolder
            Debug.Print "***     sName: " & sName

            ' Save the found folder separately
            '  as findInFolders resets to Nothing
            Set fFolder = subFolder
            ' There may be a way to exit once the folder is found
            '  otherwise run to the end

        Else
            Set findInFolders = findInFolders(subFolder.Folders, sName, fFolder)

        End If
    Next

End Function

注意：On Error Resume Next正如您在原始代码中所看到的，几乎总是对缺乏经验的程序员有害。

相关内容