Skip to content

Instantly share code, notes, and snippets.

Created June 2, 2020 18:19
What would you like to do?
This VBA Macro create Kaboard Tasks over JSON http requests
Attribute VB_Name = "Modulo1"
' usar SelfCert.exe y tools - digital signatur
' loop mails
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
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 = ""
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)
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
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)
End If
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment