Outlook VBA脚本合并：将SaveMessageAsMsg的msg2路径传入createTask

问题原因 #

原有合并失败存在两个核心问题：

• SaveMessageAsMsg中的msg2是局部变量，作用域仅在该过程内部，createTask无法直接读取
• 原有执行逻辑没有先执行邮件保存操作，直接调用createTask时路径变量还未生成

修改思路 #

• 将SaveMessageAsMsg改造为带返回值的函数，传入单个邮件对象，返回保存后的.msg文件完整路径
• 在createTask执行JSON拼接前，先调用上述保存函数获取路径，再传入JSON参数
• 统一字符串拼接符为VBA标准的&，避免隐式类型转换错误

完整合并后代码 #

' 主执行入口，遍历选中的邮件逐个处理
Sub send()
    Dim x As Object, mailItem As Outlook.mailItem
  
    For Each x In Application.ActiveExplorer.Selection
        If TypeName(x) = "MailItem" Then
            Set mailItem = x
            Call createTask(mailItem)
        End If
    Next
End Sub

Sub createTask(ByRef mItem As Outlook.mailItem)
    Dim kbUrl As String
    Dim title As String
    Dim kbUsername As String
    Dim kbPassword As String
    Dim kbProjectId As Integer
    Dim kbSwimlaneId As Integer
    Dim JsonString As String
    Dim msg2 As String ' 定义存储.msg路径的变量
    ' 调用保存邮件函数，获取文件完整路径
    msg2 = SaveMessageAsMsg(mItem)
    
    kbUrl = "https://website.com/jsonrpc.php"
    kbUsername = "test"
    kbPassword = "test"
    kbProjectId = 1
    kbSwimlaneId = 1

    Set LoginRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    LoginRequest.Option(4) = 13056
    LoginRequest.Open "POST", kbUrl, False
    LoginRequest.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    LoginRequest.SetCredentials kbUsername, kbPassword, 0
    
    title = InputBox(mItem.Subject, "Title")
    If StrPtr(title) = 0 Then
        Exit Sub ' 用户点了取消直接退出
    ElseIf title = vbNullString Then
        JsonString = "{""jsonrpc"": ""2.0"", ""method"": ""createTask"",""id"": 1176509098,""params"": {""score"": 0, ""project_id"": """ & kbProjectId & """, ""swimlane_id"":""" & kbSwimlaneId & """ , ""title"":""" & Format(mItem.CreationTime, "ddd hh:nn") & " / " & Split(mItem.SenderName)(1) & " / " & mItem.Subject & """, ""description"":""" & "[LINK](file:" & msg2 & ")""}}"
    Else
        JsonString = "{""jsonrpc"": ""2.0"", ""method"": ""createTask"",""id"": 1176509098,""params"": {""score"": 0, ""project_id"": """ & kbProjectId & """, ""swimlane_id"":""" & kbSwimlaneId & """ , ""title"":""" & Format(mItem.CreationTime, "ddd hh:nn") & " / " & Split(mItem.SenderName)(1) & " / " & title & """, ""description"":""" & "[LINK](file:" & msg2 & ")""}}"
    End If
   
    LoginRequest.Send JsonString
    If LoginRequest.Status = 200 Then
        Call buscaError(LoginRequest.responseText, mItem)
    Else
      MsgBox "The list did not respond - 200 OK"
    End If
End Sub

Function buscaError(strBuscar As String, ByRef mItem As Outlook.mailItem)
    Dim useCategory As String
    useCategory = "LIST"
    Dim RegError As RegExp
    Dim RegExito As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
    Set RegError = New RegExp
    Set RegExito = New RegExp
    
    With RegError
        .Pattern = "(error)"
        .Global = True
    End With
    With RegExito
        .Pattern = "(result)"
        .Global = True
    End With
    
    If RegError.test(strBuscar) Then
        'MsgBox "Mail processing error: " & mItem.Subject
    ElseIf RegExito.test(strBuscar) Then
        Call AddCategory(mItem, useCategory)
        'MsgBox "Ok"
    End If
End Function

Sub AddCategory(aMailItem As mailItem, newCategory As String)
    Dim categories() As String
    Dim listSep As String

    listSep = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\International\sList")
    categories = Split(aMailItem.categories, listSep)

    If UBound(Filter(categories, newCategory)) = -1 Then
        ReDim Preserve categories(UBound(categories) + 1)
        categories(UBound(categories)) = newCategory
        aMailItem.categories = Join(categories, listSep)
        aMailItem.Save
    End If
End Sub

' 改造为带返回值的函数，传入单个邮件对象，返回保存后的完整路径
Function SaveMessageAsMsg(ByVal oMail As Outlook.mailItem) As String
    Dim sPath As String
    Dim dtDate As Date
    Dim sName As String
    
    sName = oMail.Subject
    ReplaceCharsForFileName sName, "-"
     
    dtDate = oMail.ReceivedTime
    sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
         
    ' 修改为你实际的局域网存储路径
    sPath = "\\local.disk\folder\"
    SaveMessageAsMsg = sPath & sName
    oMail.SaveAs sPath & sName, olMSG
End Function

Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
    sName = Replace(sName, "'", sChr)
    sName = Replace(sName, "*", sChr)
    sName = Replace(sName, "/", sChr)
    sName = Replace(sName, "\", sChr)
    sName = Replace(sName, ":", sChr)
    sName = Replace(sName, "?", sChr)
    sName = Replace(sName, Chr(34), sChr)
    sName = Replace(sName, "<", sChr)
    sName = Replace(sName, ">", sChr)
    sName = Replace(sName, "|", sChr)
End Sub

使用注意 #

• 需先修改SaveMessageAsMsg函数中的sPath值为实际的局域网共享文件夹路径，末尾要加斜杠
• 进入Outlook VBA编辑器后，点击「工具-引用」，勾选Microsoft VBScript Regular Expressions 5.5，否则正则匹配部分会报错
• 如果共享路径需要权限，要提前确保当前Windows账号对该路径有读写权限

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