如何合并Lotus Notes邮件读取与匹配转发VBA模块实现自动运行

核心优化思路 #

• 预加载A列邮箱、B列匹配规则到内存数组，避免遍历邮件过程中反复读取工作表，运行效率更高
• 取消冗余的单元格读写操作，直接用内存变量存储当前邮件主题，减少不必要的工作表IO；如果需要保留C1展示当前处理主题的可视化效果，可保留对应写入逻辑
• 匹配逻辑直接嵌入邮件遍历循环，每读取一封邮件立刻执行匹配校验，匹配成功直接触发转发，无需等待全部邮件读取完成

合并后完整代码 #

Sub AutoForwardMatchEmails()
    Dim NSession As Object, NMailDb As Object
    Dim v As Object, vn As Object, e As Object, doc As Object
    Dim View As String, lastrow As Long, matchArr As Variant
    Dim currSubject As String, i As Long
    
    ' 配置Notes视图参数
    View = "$All"
    
    ' 初始化Notes连接
    Set NSession = CreateObject("Notes.NotesSession")
    Set NMailDb = NSession.GetDatabase("", "")
    If Not NMailDb.IsOpen Then
        NMailDb.OPENMAIL
    End If
    
    ' 预加载匹配规则到内存数组，仅读取1次工作表
    lastrow = ActiveSheet.Range("A30000").End(xlUp).Row
    matchArr = ActiveSheet.Range("A1:B" & lastrow).Value
    
    ' 初始化邮件遍历器
    Set v = NMailDb.GetView(View)
    Set vn = v.CreateViewNav()
    Set e = vn.GetFirstDocument()
    
    ' 遍历所有邮件
    Do While Not (e Is Nothing)
        Set doc = e.Document
        ' 读取当前邮件主题
        currSubject = doc.GetItemValue("subject")(0)
        
        ' 可选：保留C1写入逻辑，可视化展示当前处理的邮件主题
        Range("C1").Value = currSubject
        
        ' 执行匹配校验
        For i = 1 To UBound(matchArr, 1)
            ' 不区分大小写匹配
            If InStr(1, LCase(currSubject), LCase(matchArr(i, 2)), vbTextCompare) > 0 Then
                ' 匹配成功触发转发
                Forward_Email currSubject, matchArr(i, 1)
                ' 若同一主题仅需匹配第一条规则，可取消下一行注释
                ' Exit For
            End If
        Next i
        
        ' 处理下一封邮件
        Set e = vn.GetNextDocument(e)
    Loop
    
    ' 释放对象
    Set e = Nothing: Set vn = Nothing: Set v = Nothing
    Set NMailDb = Nothing: Set NSession = Nothing
End Sub

注意事项 #

• 运行前需保持Lotus Notes收件箱已打开，和原有运行要求一致
• 若B列存在重复的匹配规则，同一封邮件会触发多次转发，可根据业务需要开启匹配后跳出循环的逻辑
• 可自行调整InStr函数的参数，修改为区分大小写匹配、全字匹配等规则
• 如果需要标记已处理邮件避免重复转发，可在匹配成功后给Notes邮件添加已处理标记，下次遍历跳过已标记邮件

内容的提问来源于stack exchange，提问作者Drawleeh