![Outlook 在电子邮件上运行 VBA 脚本,根据主题中的 6 位数字移动到文件夹](https://linux22.com/image/1579858/Outlook%20%E5%9C%A8%E7%94%B5%E5%AD%90%E9%82%AE%E4%BB%B6%E4%B8%8A%E8%BF%90%E8%A1%8C%20VBA%20%E8%84%9A%E6%9C%AC%EF%BC%8C%E6%A0%B9%E6%8D%AE%E4%B8%BB%E9%A2%98%E4%B8%AD%E7%9A%84%206%20%E4%BD%8D%E6%95%B0%E5%AD%97%E7%A7%BB%E5%8A%A8%E5%88%B0%E6%96%87%E4%BB%B6%E5%A4%B9.png)
我们公司为项目使用一个 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
正如您在原始代码中所看到的,几乎总是对缺乏经验的程序员有害。