Refined VBA Logic for Launching TI Process

[WilliamSmith]

Hi all,

Below is a refinement to the VBA code I use to launch TI processes via the TM1 Rest API. Wanted to share to help our community in case someone finds it useful.

The refinement uses the async polling method. I've found the older sync endpoint has undefined behavior, as far how long it will maintain the http connection. For long running tasks, it would sometimes return to the calling VBA script with no return. This new scripting mitigates that concern.

It requires a VBA reference to:

• Microsoft Scripting Runtime
• Microsoft XML, v6.0

And an external VBA module:

• https://github.com/VBA-tools/VBA-JSON

Code: Select all

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

Function TM1_Run_Process_With_Polling(processName As String, Optional paramDictionary As Dictionary, Optional timeoutSeconds = 60) As String

On Error GoTo ErrHandler
    
    Dim payload As String
    Dim runStatus As String
    Dim responseText As String
    
    payload = ""

    runStatus = ""

    If Not paramDictionary Is Nothing Then

        payload = "{""Parameters"":["
        
        For Each Key In paramDictionary.Keys
        
            payload = payload & "{""Name"":""" & Key & """, ""Value"":""" & paramDictionary(Key) & """},"
        
        Next
        
        payload = payload & "]}"
        
    End If
    
    Dim x As MSXML2.ServerXMLHTTP60
    Set x = New MSXML2.ServerXMLHTTP60
    
    x.Open "POST", "https://[YourServer]:[YourPort]/api/v1/Processes('" & processName & "')/tm1.ExecuteWithReturn", False, "[YourUserName]", "[YourPassword]"
    x.setRequestHeader "WWW-Authenticate: Basic Realm", "TM1"
    x.setRequestHeader "Content-Type", "application/json"
    x.setRequestHeader "Accept", "application/json"
    x.setRequestHeader "Prefer", "respond-async"
    x.SetOption 2, 13056
    
    x.send payload
    
    Dim asyncId As String
    asyncId = ExtractAsyncID(x.getResponseHeader("Location"))
          
    Dim counter As Integer
    counter = 1
        
    Do While True
          
        x.Open "GET", "https://[YourServer]:[YourPort]/api/v1/_async('" & asyncId & "')", False, "[YourUserName]", "[YourPassword]"
        x.setRequestHeader "Accept", "application/json"
        x.send
        
        If counter = timeoutSeconds Then
            
            Err.Raise 17, , "The requested operation timed out."
        
        End If
        
        If x.Status = 200 Or x.Status = 201 Then
        
            responseText = x.responseText
            Exit Do
            
        End If
        
        counter = counter + 1
        
        Sleep 1000
        
    Loop
    
    Dim json As Object
    Set json = JsonConverter.ParseJson(responseText)

    runStatus = json("ProcessExecuteStatusCode")

ErrHandler:

    If Err.Number <> 0 Then
    
        Err.Raise 17, , "VBA Script Error!: " & Err.Description
    
    End If

    If runStatus <> "CompletedSuccessfully" Then

        MsgBox "Turbo Integrator script error!: " & runStatus

    End If
    
    TM1_Run_Process_With_Polling = runStatus

End Function

Function ExtractAsyncID(inputString As String) As String

    Dim startPos As Integer
    Dim endPos As Integer
    Dim idLength As Integer
    Dim extractedID As String
    
    startPos = InStr(inputString, "_async('") + Len("_async('")
    
    endPos = InStr(startPos, inputString, "')") - 1
    
    idLength = endPos - startPos + 1
    
    extractedID = Mid(inputString, startPos, idLength)
    
    ExtractAsyncID = extractedID
    
End Function

Example of calling a TI script:

Code: Select all

Sub AddNewProjectCode()

    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    Dim parameters As New Dictionary
    parameters.Add "projectCode", Trim(wb.Names("AlphaCode").RefersToRange.Value)

    TM1_Run_Process_With_Polling "AddNewProjectCode", parameters

    parameters.RemoveAll
    
    
    'Save Data
    TM1_Run_Process_With_Polling "savedata"

End Sub