This VBA Macro create Kaboard Tasks over JSON http requests

OutlookMail2Task

Attribute VB_Name = "Modulo1"
' usar SelfCert.exe y tools - digital signatur
' loop mails
' https://www.slipstick.com/developer/outlook-vba-work-with-open-item-or-select-item/

Sub loopMails()
    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
    
    MsgBox "Creando tareas de Kanboard finalizado"

End Sub


Sub createTask(ByRef mItem As Outlook.mailItem)
    Dim kbUrl As String
    Dim kbUsername As String
    Dim kbPassword As String
    Dim kbProjectId As Integer 'Project ID /board/7
    Dim kbSwimlaneId As Integer 'View swimline edit url
    kbUrl = "https://example.com/jsonrpc.php"
    kbUsername = "myUser"
    kbPassword = "ba5263eef800ac0acc0cfc54a6bd77c486964fd40bed10a0d27c4b3df8bd"
    kbProjectId = 1
    kbSwimlaneId = 8

    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
    
    JsonString = "{""jsonrpc"": ""2.0"", ""method"": ""createTask"",""id"": 1176509098,""params"": {""score"": 0, ""project_id"": """ & kbProjectId & """, ""swimlane_id"":""" & kbSwimlaneId & """ , ""title"":""" & mItem.Subject & """, ""reference"":""" & mItem.SenderName & """}}"
    
    LoginRequest.Send JsonString
    If LoginRequest.Status = 200 Then
        'MsgBox "Correo: " & mItem.Subject & " - Estado: " & LoginRequest.responseText
        Call buscaError(LoginRequest.responseText, mItem)
        'Texto = Split(LoginRequest.responseText, """result"":")
        'MsgBox "str es" & CStr(Texto)
    Else
      MsgBox "Kanboard no respondio 200 OK - Ver el servidor"
    End If

End Sub


Function buscaError(strBuscar As String, ByRef mItem As Outlook.mailItem)
 ' Set reference to VB Script library
 ' Microsoft VBScript Regular Expressions 5.5
    Dim useCategory As String
    useCategory = "enKanboard"
    '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)
   ' Debug.Print olMail.Body
    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
        'Set M1 = Reg1.Execute(strBuscar)
        'For Each M In M1
        MsgBox "Error procesando el correo: " & mItem.Subject
        'Next
        
    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

    ' Get the current list separator from Windows regional settings
    listSep = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\International\sList")

    ' Break the list up into an array
    categories = Split(aMailItem.categories, listSep)

    ' Search the array for the new cateogry, and if it is missing, then add it
    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