Connect to a TM1 Server with IBM Cognos CAM Security Mode 4 and 5 for 64bit Excel VBA

CAMPassport.md

IBM has provided a dll to support VBA logging into TM1 using CAMPassport integrated authentication within Excel. The dll is 32 bit only and the supplied excel file does not run in 64 bit Excel.

Hopefully one of these is a permanent link to the article and link https://www.ibm.com/support/pages/uid/swg21959177 https://www.ibm.com/support/pages/tm1-api-excel-vba-coding-and-library-automatically-connect-tm1-server-ibm-cognos-cam-security-mode-4-and-5

These are the steps required to get the xlsm file provided by IBM working in 64 bit office. Or the updated VBA module is in the second file of this gist.

When opening TEST_CAM_CONNECT.xlsm the system throws up errors that the funtions are not compatible with 64 bit office.

• Search Replace "Declare Function" with "Declare PtrSafe Function"
• Search Replace "Declare Sub" with "Declare PtrSafe Sub"
• Search Replace "As Long" "As LongLong" It will make a couple of incorrect changes
  • Change back one instance of "As LongLongPtr" to "As LongPrt"
  • Change back "Dim lLenB As LongLong" to "Dim lLenB As Long" or the ReDim in that function will cause type mismatch errors
  • Change back "Dim cSize As LongLong" to "Dim cSize As Long" and
  • Update next line to cast the returned value to Long so it looks like "cSize = CLng(2 * TM1ValStringWMaxSize(hUser, vString))"
• Comment out the 2 lines containing n_connect_cam_bridge.dll one is a definition and the other loads the library. This is a 32 bit dll and won't work.
  • Replace "If rcApi = 0 Or rcCon = 0 Then" with "If rcApi = 0 Then" since the rcCon assignment from the missing library load has been commented out
• Add the new GetCamPassport function. Copy it out of the second file in this gist.
  • Replace "sPassportLong = Trim(Left(StrConv(sPassportLong, vbFromUnicode), 255))" with "sPassportLong = Trim(Left(sPassportLong, 255))" The new GetCamPassport functions returns the passport non-unicode encoded.
• Update TEST_N_CONNECT_CAM() with correct connection details, load perspectives, and run the sub to test everything works.

CAMPassport.vba

Option Explicit

'General
Private Declare PtrSafe Function TM1_API2HAN Lib "tm1.xll" () As LongLong
Private Declare PtrSafe Function TM1ValPoolCreate Lib "tm1api.dll" (ByVal hUser As LongLong) As LongLong
Private Declare PtrSafe Sub TM1ValPoolDestroy Lib "tm1api.dll" (ByVal hPool As LongPtr)
Private Declare PtrSafe Function TM1SystemGetServerConfig Lib "tm1api.dll" (ByVal hPool As LongLong, ByVal sServer As LongLong) As LongLong
Private Declare PtrSafe Function TM1SystemServerConnectWithCAMPassport Lib "tm1api.dll" (ByVal hPool As LongLong, ByVal sServer As LongLong, ByVal camArgs As LongLong) As LongLong
Private Declare PtrSafe Sub TM1SystemAdminHostSet Lib "tm1api.dll" (ByVal hUser As LongLong, ByVal AdminHosts As String)

'Value properties
Private Declare PtrSafe Function TM1ValTypeArray Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ValTypeBool Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ValTypeError Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ValTypeIndex Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ValTypeObject Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ValTypeReal Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ValTypeString Lib "tm1api.dll" () As LongLong

'Value Type
Private Declare PtrSafe Function TM1ValType Lib "tm1api.dll" (ByVal hUser As LongLong, ByVal value As LongLong) As Integer

'Value String
Private Declare PtrSafe Function TM1ValStringW Lib "tm1api.dll" (ByVal hPool As LongLong, ByRef InitString As Any, ByVal MaxSize As LongLong) As LongLong
Private Declare PtrSafe Function TM1ValStringMaxSize Lib "tm1api.dll" (ByVal hUser As LongLong, ByVal vString As LongLong) As LongLong
Private Declare PtrSafe Sub TM1ValStringGetW_VB Lib "tm1api.dll" (ByVal hUser As LongLong, ByVal vString As LongLong, ByRef res As Any, ByVal max As LongLong)
Private Declare PtrSafe Function TM1ValStringWMaxSize Lib "tm1api.dll" (ByVal hUser As LongLong, ByVal vString As LongLong) As LongLong

'Value Array
Private Declare PtrSafe Function TM1ValArray Lib "tm1api.dll" (ByVal hPool As LongLong, ByRef sArray() As LongLong, ByVal MaxSize As LongLong) As LongLong
Private Declare PtrSafe Function TM1ValArrayGet Lib "tm1api.dll" (ByVal hUser As LongLong, ByVal vArray As LongLong, ByVal index As LongLong) As LongLong
Private Declare PtrSafe Function TM1ValArrayMaxSize Lib "tm1api.dll" (ByVal hUser As LongLong, ByVal vArray As LongLong) As LongLong
Private Declare PtrSafe Sub TM1ValArraySet Lib "tm1api.dll" (ByVal vArray As LongLong, ByVal val As LongLong, ByVal index As LongLong)
Private Declare PtrSafe Sub TM1ValArraySetSize Lib "tm1api.dll" (ByVal vArray As LongLong, ByVal Size As LongLong)

'Errors
Private Declare PtrSafe Function TM1ErrorSystemServerClientPasswordExpired Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorSystemServerClientAlreadyConnected Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorSystemServerClientConnectFailed Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorSystemServerNotFound Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorSystemOutOfMemory Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorSystemServerIncompatibleVersion Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorSystemServerMaxConnectionsExceeded Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorClientMaximumPortsExceeded Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorSystemServerIsInShutdownMode Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorSystemServerClientExceedMaxLogonNumber Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorSystemServerIntegratedSecurityRequired Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorSystemServerIntegratedSecurityRefused Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ErrorAuthorizedConnectionFailed Lib "tm1api.dll" () As LongLong
Private Declare PtrSafe Function TM1ValErrorCode Lib "tm1api.dll" (ByVal hUser As LongLong, ByVal vError As LongLong) As LongLong

'Windows
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As LongLong)
Declare PtrSafe Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As LongLong, ByVal dwFlags As LongLong) As LongLong

'TM1 CAM CONNECT BRIDGE
'Private Declare PtrSafe Function GetCamPassport Lib "n_connect_cam_bridge.dll" (ByVal camuri As String, ByVal servername As String, ByVal passport As String, ByVal Size As LongLong) As LongLong

Public Const LOAD_WITH_ALTERED_SEARCH_PATH = &H8&
Dim libPath As String

Public Sub TEST_N_CONNECT_CAM()

    'these will be a parameter
    Dim sAdminHost As String
    Dim sServerName As String
    sAdminHost = "servername.internaldomain"
    sServerName = "QACAM"

    N_CONNECT_CAM sAdminHost, sServerName

End Sub

Private Function GetCamPassport(ByVal camuri As String, ByVal servername As String, ByRef passport As String, ByVal Size As LongLong) As LongLong
    On Error GoTo ErrorHandler:
    
    Dim sResponseHeaders, sResponseText, sCamPassport, aData, sUrl, oMatch
    sUrl = StrConv(camuri, vbFromUnicode)
    
    With CreateObject("WinHttp.WinHttpRequest.5.1")
         .Open "GET", sUrl, False
         .setRequestHeader "Accept", "application/json"
         .setRequestHeader "Content-Type", "application/json; charset=utf-8"
         .SetAutoLogonPolicy (0) '(AutoLogonPolicy_Always) 'Connect using current user credentials
         .Send
         sResponseHeaders = .getAllResponseHeaders
         sResponseText = .responseText
    End With
    
    aData = Array()
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .Pattern = "^Set-Cookie: cam_passport=(\S*?);[\s\S]*?$"
        For Each oMatch In .Execute(sResponseHeaders)
            If oMatch.SubMatches.Count = 1 Then
                sCamPassport = oMatch.SubMatches(0)
            End If
        Next
    End With
    
    'passport = StrConv(sCamPassport, vbUnicode) ' This works here but results in the function returning a badly padded passport
    passport = sCamPassport
    GetCamPassport = 0

    Exit Function
    
ErrorHandler:
    GetCamPassport = 2
End Function

Private Sub N_CONNECT_CAM(sAdminHost As String, sServerName As String)

    Dim hUser As LongLong
    Dim hPool As LongLong
    Dim hServerName As LongLong
    Dim hServer As LongLong
    Dim hServerConfig As LongLong
    Dim vArr As LongLong
    Dim vArrItem As LongLong
    Dim sCamURI As String
    Dim hCamArgs As LongLong
    Dim voParamArray(1) As LongLong
    Dim ret As LongLong
    Dim sPassportLong As String * 255
    Dim sPassport As String
    Dim hPassport As LongLong

    Dim rcCon As LongLong
    Dim rcApi As LongLong

    'ensure tm1p.xla is loaded
    If Not TM1PExists Then
        Debug.Print "TM1 Perspectives is not loaded"
        Exit Sub
    End If

    'loading libraries
    If libPath = "" Then
        Debug.Print "Error getting library path"
        GoTo Done
    End If
    rcApi = LoadLibraryEx(libPath & "\tm1api.dll", 0, LOAD_WITH_ALTERED_SEARCH_PATH)
    'rcCon = LoadLibraryEx(libPath & "\n_connect_cam_bridge.dll", 0, LOAD_WITH_ALTERED_SEARCH_PATH)

    If rcApi = 0 Then 'Or rcCon = 0 Then
        Debug.Print "Error loading libraries"
        GoTo Done
    End If

    'getting user handle from perspectives
    hUser = TM1_API2HAN()
    'setting the admin host
    TM1SystemAdminHostSet hUser, sAdminHost

    'memory allocation
    hPool = TM1ValPoolCreate(hUser)

    'getting the configuration from the server
    hServerName = TM1ValString(hPool, sServerName, 0)
    hServerConfig = TM1SystemGetServerConfig(hPool, hServerName)

    If TM1ValType(hUser, hServerConfig) = TM1ValTypeError() Then
        Debug.Print "Error getting configuration from server " & sServerName
        GoTo Done
    End If

    vArr = TM1ValArrayGet(hUser, hServerConfig, 2)
    vArrItem = TM1ValArrayGet(hUser, vArr, 1)

    'getting the cam uri from the configuration
    If TM1ValType(hUser, vArrItem) = TM1ValTypeString() Then
        TM1ValStringGet_VB hUser, vArrItem, sCamURI, 0
    Else
        Debug.Print "Error getting CAMURI"
        GoTo Done
    End If

    'getting the passport from the cam environment
    ret = GetCamPassport(StrConv(sCamURI, vbUnicode), StrConv(sServerName, vbUnicode), sPassportLong, 255)
    If ret > 0 Then
        Debug.Print "Error getting passport"
    End If
    'sPassportLong = Trim(Left(StrConv(sPassportLong, vbFromUnicode), 255))
    sPassportLong = Trim(Left(sPassportLong, 255))
    Dim i As Integer
    i = InStr(sPassportLong, Chr(0))
    If (i > 0) Then
        sPassport = Trim(Left(sPassportLong, i - 1))
    Else
        sPassport = Trim(sPassportLong)
    End If

    If sPassport = "" Then
        Debug.Print "Error getting passport (empty)"
        GoTo Done
    End If

    'connecting to TM1 using the passport
    hCamArgs = TM1ValArray(hPool, voParamArray, 1)
    If TM1ValType(hUser, hCamArgs) = TM1ValTypeError() Then
        Debug.Print "Error creating array for cam arguments"
        HandleServerConnectionError hUser, hServer
        GoTo Done
    End If

hPassport = TM1ValString(hPool, sPassport, 0)
TM1ValArraySet hCamArgs, hPassport, 1

hServer = TM1SystemServerConnectWithCAMPassport(hPool, hServerName, hCamArgs)

If TM1ValType(hUser, hServer) = TM1ValTypeError() Then
    Debug.Print "Error connecting to the server"
    GoTo Done
End If

Done:
If hPool > 0 Then
    TM1ValPoolDestroy (hPool)
End If

End Sub

Private Function TM1ValString(ByVal hPool As LongLong, ByVal InitString As String, ByVal MaxSize As LongLong) As LongLong
    Dim buf() As Byte

    buf = StringToByteArray(InitString, True, True)
    TM1ValString = TM1ValStringW(hPool, buf(0), MaxSize)

End Function

Private Function StringToByteArray(strInput As String, _
                                Optional bReturnAsUnicode As Boolean = True, _
                                Optional bAddNullTerminator As Boolean = False) As Byte()
    
    Dim bytBuffer() As Byte
    Dim lLenB As Long

    If bReturnAsUnicode Then        'UTF-16
        lLenB = LenB(strInput)
        If bAddNullTerminator Then
            ReDim bytBuffer(lLenB + 1)
        Else
            ReDim bytBuffer(lLenB - 1)
        End If
        CopyMemory bytBuffer(0), ByVal StrPtr(strInput), lLenB
    Else                            'ANSI
        bytBuffer = StrConv(strInput, vbFromUnicode)
    End If
    
    StringToByteArray = bytBuffer
    
End Function

Private Sub TM1ValStringGet_VB(ByVal hUser As LongLong, ByVal vString As LongLong, ByRef res As String, ByVal max As Integer)

       Dim buf() As Byte
       Dim cSize As Long
       'cSize = 2 * TM1ValStringWMaxSize(hUser, vString)
       cSize = CLng(2 * TM1ValStringWMaxSize(hUser, vString))
        If cSize = 0 Then
            res = ""
        Else
    
            ReDim buf(cSize - 1)
            TM1ValStringGetW_VB hUser, vString, buf(0), cSize
            res = Left(buf, cSize)
             'remove the trailing null string and spaces
            Dim i As Integer
            i = InStr(res, Chr(0))
            If (i > 0) Then
                res = Trim(Left(res, i - 1))
            Else
                res = Trim(res)
            End If
            
       End If
End Sub

Private Sub HandleServerConnectionError(hUser As LongLong, hServer As LongLong)

Dim err1 As LongLong
Dim err2 As LongLong
Dim err3 As LongLong
Dim err4 As LongLong
Dim err5 As LongLong
Dim err6 As LongLong
Dim err7 As LongLong
Dim err8 As LongLong
Dim err9 As LongLong
Dim err10 As LongLong
Dim err11 As LongLong
Dim err12 As LongLong
Dim err13 As LongLong
Dim err14 As LongLong

Dim errorcode As LongLong

err1 = TM1ErrorSystemServerClientPasswordExpired()
err2 = TM1ErrorSystemServerClientAlreadyConnected()
err3 = TM1ErrorSystemServerClientConnectFailed()
err4 = TM1ErrorSystemServerClientConnectFailed()
err5 = TM1ErrorSystemServerNotFound()
err6 = TM1ErrorSystemOutOfMemory()
err7 = TM1ErrorSystemServerIncompatibleVersion()
err8 = TM1ErrorSystemServerMaxConnectionsExceeded()
err9 = TM1ErrorClientMaximumPortsExceeded()
err10 = TM1ErrorSystemServerIsInShutdownMode()
err11 = TM1ErrorSystemServerClientExceedMaxLogonNumber()
err12 = TM1ErrorSystemServerIntegratedSecurityRequired()
err13 = TM1ErrorSystemServerIntegratedSecurityRefused()
err14 = TM1ErrorAuthorizedConnectionFailed()

errorcode = TM1ValErrorCode(hUser, hServer)

If errorcode = err1 Then Debug.Print "TM1ErrorSystemServerClientPasswordExpired"
If errorcode = err2 Then Debug.Print "TM1ErrorSystemServerClientAlreadyConnected"
If errorcode = err3 Then Debug.Print "TM1ErrorSystemServerClientConnectFailed"
If errorcode = err4 Then Debug.Print "TM1ErrorSystemServerClientConnectFailed"
If errorcode = err5 Then Debug.Print "TM1ErrorSystemServerNotFound"
If errorcode = err6 Then Debug.Print "TM1ErrorSystemOutOfMemory"
If errorcode = err7 Then Debug.Print "TM1ErrorSystemServerIncompatibleVersion"
If errorcode = err8 Then Debug.Print "TM1ErrorSystemServerMaxConnectionsExceeded"
If errorcode = err9 Then Debug.Print "TM1ErrorClientMaximumPortsExceeded"
If errorcode = err10 Then Debug.Print "TM1ErrorSystemServerIsInShutdownMode"
If errorcode = err11 Then Debug.Print "TM1ErrorSystemServerClientExceedMaxLogonNumber"
If errorcode = err12 Then Debug.Print "TM1ErrorSystemServerIntegratedSecurityRequired"
If errorcode = err13 Then Debug.Print "TM1ErrorSystemServerIntegratedSecurityRefused"
If errorcode = err14 Then Debug.Print "TM1ErrorAuthorizedConnectionFailed"

End Sub

Public Function TM1PExists() As Boolean
    On Error GoTo error_handler
    TM1PExists = False
    Dim ad As AddIn
    ' First look in the addins collection
    For Each ad In Application.AddIns
        If ad.Name = "tm1p.xla" And ad.Installed = True Then
            TM1PExists = True
            libPath = ad.Path
            Exit Function
        End If
    Next
    
    Dim bk As Workbook
    ' next look in the workbooks collection (if opened as a normal book)
    For Each bk In Application.Workbooks
        If bk.Name = "tm1p.xla" Then
            TM1PExists = True
            libPath = bk.Path
            Exit Function
        End If
    Next
    ' finally ask for the book by name
    Set bk = Application.Workbooks("tm1p.xla")
    If Not bk Is Nothing Then
        TM1PExists = True
        libPath = bk.Path
        Exit Function
    End If

    Exit Function
error_handler:
    TM1PExists = False
    Err.Clear
End Function