Could you call the token service with a Basic Auth account like so?
Not exaclty SSO but getâs rid of the login prompt.
Option Explicit
Public Const stBaseUrl As String = "https://xxx.epicorsaas.com/xxx/api/v2/odata/xxxxxx"
Public Const stAPIKey As String = "KWwNYuijBwbkc......................................................."
Public Const stCredentials As String = "UserName" & ":" & "Password"
Public stUrl As String
Public stTokenResponse As String
'Public ri As New Dictionary
Sub Button1_Click()
Dim stResponse As String
stResponse = CallBAQ()
Range("G4").Value = stResponse
End Sub
Function CallBAQ() As String
Dim http As New MSXML2.XMLHTTP60
Dim stUrl As String, stPostBody, stResponse As String, sSuccess As Boolean
stUrl = stBaseUrl & "/BaqSvc/baq_PartPrice/Data?PartNum='PL0011000'&$filter=Calculated_PrimarySupplier eq true"
Set http = CallEpicorAPI("GET", stUrl, "", True, "")
If http.ReadyState = 4 And (http.Status = 200 Or http.Status = 202) Then
stResponse = http.responseText
sSuccess = True
Else
stResponse = "Error" & vbNewLine & "Ready state: " & http.ReadyState & _
vbNewLine & "HTTP request status: " & http.Status & _
vbNewLine & http.responseText
sSuccess = False
MsgBox stResponse
End If
'Log stAction, stURL, CStr(stPostBody), blnAuthorize, http
Exit_Function:
CallBAQ = stResponse
Set http = Nothing
End Function
Function CallEpicorAPI(stAction As String, stUrl As String, stPostBody As Variant, blnAuthorize As Boolean, Optional stContentType As String) As MSXML2.XMLHTTP60
Dim http As New MSXML2.XMLHTTP60
Dim stResponse As String, sSuccess As Boolean
http.Open stAction, stUrl, False
If IsMissing(stContentType) Or 0 = Len(stContentType) Then stContentType = "application/json"
http.setRequestHeader "Content-Type", stContentType
http.setRequestHeader "x-api-key", stAPIKey
If blnAuthorize Then http.setRequestHeader "Authorization", "Bearer " & GetToken()
http.Send stPostBody
If http.ReadyState = 4 And (http.Status = 200 Or http.Status = 202) Then
stResponse = http.responseText
' sSuccess = True
'Else
' MsgBox "Error" & vbNewLine & "Ready state: " & http.ReadyState & _
' vbNewLine & "HTTP request status: " & http.Status & _
' vbNewLine & http.responseText
' sSuccess = False
End If
'Log stAction, stURL, CStr(stPostBody), blnAuthorize, http
Exit_Function:
Set CallEpicorAPI = http
Set http = Nothing
End Function
Function GetToken() As String
Dim http As New MSXML2.XMLHTTP60
Dim stTokenURL As String, stBase64Credentials As String, stPostBody As String, stResponse As String
stTokenURL = stBaseUrl & "/Ice.Lib.TokenServiceSvc/GetAccessToken"
stPostBody = "{""clientId"": ""00000000-0000-0000-0000-000000000000"",""clientSecret"": ""string"",""scope"": ""string""}"
stBase64Credentials = EncodeBase64(stCredentials)
http.Open "POST", stTokenURL, False
http.setRequestHeader "Authorization", "Basic " & stBase64Credentials
http.setRequestHeader "x-api-key", stAPIKey
http.setRequestHeader "Content-Type", "application/json"
http.Send stPostBody
If http.ReadyState = 4 And http.Status = 200 Then
stTokenResponse = http.responseText
stResponse = ParseJson(stTokenResponse, "AccessToken", "TokenService")
Else
MsgBox "Error" & vbNewLine & "Ready state: " & http.ReadyState & _
vbNewLine & "HTTP request status: " & http.Status & _
vbNewLine & http.responseText
End If
Exit_Function:
GetToken = stResponse
Set http = Nothing
End Function
Function ParseJson(json As String, stPropName As String, Optional stParseFrom As String = "") As String
Dim arrStart As Long, arrEnd As Long
Dim arrJson As String
Dim key As String
Dim startPos As Long, endPos As Long
Dim result As String
' If stParseFrom is provided, find the array/object first
If stParseFrom <> "" Then
arrStart = InStr(1, json, """" & stParseFrom & """:[", vbTextCompare)
If arrStart = 0 Then
ParseJson = ""
Exit Function
End If
arrStart = arrStart + Len(stParseFrom) + 3 ' move past "TokenService":[
arrEnd = InStr(arrStart, json, "]")
If arrEnd = 0 Then
ParseJson = ""
Exit Function
End If
arrJson = Mid(json, arrStart, arrEnd - arrStart)
Else
arrJson = json
End If
key = """" & stPropName & """" & ":"
startPos = InStr(1, arrJson, key, vbTextCompare)
If startPos = 0 Then
ParseJson = ""
Exit Function
End If
startPos = startPos + Len(key)
' Skip spaces and quotes
Do While Mid(arrJson, startPos, 1) = " " Or Mid(arrJson, startPos, 1) = """"
startPos = startPos + 1
Loop
endPos = InStr(startPos, arrJson, """")
If endPos = 0 Then
ParseJson = ""
Exit Function
End If
result = Mid(arrJson, startPos, endPos - startPos)
ParseJson = result
End Function
Function EncodeBase64(text As String) As String
Dim arrData() As Byte
arrData = StrConv(text, vbFromUnicode)
Dim objXML As Object
Dim objNode As Object
Set objXML = CreateObject("MSXML2.DOMDocument")
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
EncodeBase64 = Replace(objNode.text, vbLf, "")
Set objNode = Nothing
Set objXML = Nothing
End Function
Function CallMSGraphAPI(stAction As String, stUrl As String, stPostBody As Variant, blnAuthorize As Boolean, Optional stContentType As String) As MSXML2.XMLHTTP60
Dim http As New MSXML2.XMLHTTP60
Dim stResponse As String, sSuccess As Boolean
http.Open stAction, stUrl, False
If IsMissing(stContentType) Or 0 = Len(stContentType) Then stContentType = "application/json"
http.setRequestHeader "Content-Type", stContentType
If blnAuthorize Then http.setRequestHeader "Authorization", "Bearer " & GetMSToken()
http.Send stPostBody
If http.ReadyState = 4 And (http.Status = 200 Or http.Status = 202) Then
stResponse = http.responseText
' sSuccess = True
'Else
' MsgBox "Error" & vbNewLine & "Ready state: " & http.ReadyState & _
' vbNewLine & "HTTP request status: " & http.Status & _
' vbNewLine & http.responseText
' sSuccess = False
End If
'Log stAction, stURL, CStr(stPostBody), blnAuthorize, http
Exit_Function:
Set CallMSGraphAPI = http
Set http = Nothing
End Function
