VBA

Question

我在将两个脚本合并为一个时遇到问题，我尝试将脚本“createTask”添加为文本，“SaveMessageAsMsg”脚本中的“msg2”。

当我尝试合并时，要么没有提取 msg2，要么 createtask 脚本没有正确执行。

下面的脚本是将选中的邮件保存在本地网络中，并将地址提取到这个保存的.msg元素中，这个地址将在msg2下的“createTask”脚本的JsonString中作为文本使用。

如果有人知道如何将其结合起来，我将不胜感激。

Sub send()
    Dim Sarasa As Object
    Dim x, 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
    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
    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
        'MsgBox "Mail: " & mItem.Subject & " - Status: " & LoginRequest.responseText
        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 olMail As Outlook.mailItem
    Dim RegError As RegExp
    Dim RegExito As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
    Set olMail = Application.ActiveExplorer().Selection(1)
    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

有了这个

Public Sub SaveMessageAsMsg()
      Dim oMail As Outlook.mailItem
      Dim objItem As Object
      Dim sPath As String
      Dim dtDate As Date
      Dim sName As String
      Dim msg2 As String

       For Each objItem In ActiveExplorer.Selection
       If objItem.MessageClass = "IPM.Note" Then
        Set oMail = objItem
       
      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"
        msg2 = sPath & sName
      oMail.SaveAs sPath & sName, olMSG
    
      End If
      Next
      
    End Sub

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

Answer 1

您可以将函数拆分为两个单独的函数。在这两种情况下，您都会检索当前选定的邮件项目，因此在获取对象后，您可以调用两个单独的函数来完成工作。

Sub send()
    Dim Sarasa As Object
    Dim x, mailItem As Outlook.mailItem
  
    For Each x In Application.ActiveExplorer.Selection
        If TypeName(x) = "MailItem" Then
            Set mailItem = x
            Call createTask(mailItem)
            Call SaveMessageAsMsg(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
    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
    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
        'MsgBox "Mail: " & mItem.Subject & " - Status: " & LoginRequest.responseText
        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 olMail As Outlook.mailItem
    Dim RegError As RegExp
    Dim RegExito As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
    Set olMail = Application.ActiveExplorer().Selection(1)
    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

Public Sub SaveMessageAsMsg(ByVal oMail As Outlook.mailItem)
      Dim sPath As String
      Dim dtDate As Date
      Dim sName As String
      Dim msg2 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"
        msg2 = sPath & sName
      oMail.SaveAs sPath & sName, olMSG
    
      End If
End Sub

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

VBA - 合并两个脚本

VBA - Merging two scripts

outlook