Private Sub BtnBearer_Click()
Endpoint = Cells(1, 2) & "/oauth2/v0/token"
Payload = "client_id=" & Cells(2, 2) & "&client_secret=" & Cells(3, 2) & "&grant_type=refresh_token" & "&refresh_token=" & Cells(4, 2)
Dim Json As Object
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
xmlhttp.Open "POST", endpoint, False
xmlhttp.setRequestHeader "User-Agent", "HTTP/1.1"
xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlhttp.setRequestHeader "Accept", "application/json"
xmlhttp.setRequestHeader "Host", "us2.api.concursolutions.com"
xmlhttp.setRequestHeader "Connection", "close"
xmlhttp.setRequestHeader "Content-Length", "167"
xmlhttp.setRequestHeader "concur-correlationid", "ExcelVBA-Gpaparelli"
'On Error Resume Next
xmlhttp.Send Payload
Debug.Print xmlhttp.ResponseText
Set Json = ParseJson(xmlhttp.ResponseText)
Cells(7, 2).Value = Blank
Cells(7, 2).Value = Json("access_token")
Set xmlhttp = Nothing
End Sub
endpoint = Cells(1, 2) & "/oauth2/v0/token"
Payload = "client_id=" & Cells(2, 2) & "&client_secret=" & Cells(3, 2) & "&grant_type=refresh_token" & "&refresh_token=" & Cells(4, 2)
"username=$username&password=$password&grant_type=password&client_secret=$c
lient_secret&client_id=$client_id"
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
xmlhttp.Open "POST", endpoint, False
xmlhttp.setRequestHeader "User-Agent", "HTTP/1.1"
xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlhttp.setRequestHeader "Accept", "application/json"
xmlhttp.setRequestHeader "Host", "us2.api.concursolutions.com"
xmlhttp.setRequestHeader "Connection", "close"
xmlhttp.setRequestHeader "Content-Length", "167"
xmlhttp.setRequestHeader "concur-correlationid", "ExcelVBA-Gpaparelli"
'On Error Resume Next
xmlhttp.Send Payload
Set Json = ParseJson(xmlhttp.ResponseText)
Cells(7, 2).Value = Blank
Cells(7, 2).Value = Json("access_token")
Dim Json As Object
Dim Line As Integer
Dim iLines As Integer
Dim iCount As Integer
Endpoint = Worksheets("Credentials").Cells(1, 2) & "/profile/identity/v4/Users?filter=userName eq "
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
iLines = Worksheets("Cash Advances").UsedRange.Rows.Count
iCount = 4
If iCount > iLines Then
Stop
End If
While iCount <= iLines
If (Cells(iCount, 1).Value <> "X") And (IsEmpty(Cells(iCount, 3))) Then
Current_Endpoint = Endpoint & Cells(iCount, 2)
xmlhttp.Open "GET", Current_Endpoint, False
xmlhttp.setRequestHeader "Content-Type", "application/json"
xmlhttp.setRequestHeader "Accept", "application/json"
xmlhttp.setRequestHeader "concur-correlationid", "ExcelVBA-Gpaparelli"
xmlhttp.setRequestHeader "Authorization", "Bearer " & Worksheets("Credentials").Cells(7, 2)
xmlhttp.Send
Debug.Print xmlhttp.ResponseText
Set Json = ParseJson(xmlhttp.ResponseText)
For Each Item In Json("Resources")
Debug.Print Item("id")
Cells(iCount, 3).Value = Item("id")
Next Item
Set Json = Nothing
Set Item = Nothing
End If
iCount = iCount + 1
Wend
'Release object
Set xmlhttp = Nothing
Endpoint = Worksheets("Credentials").Cells(1, 2) & "/profile/identity/v4/Users?filter=userName eq "
iLines = Worksheets("Cash Advances").UsedRange.Rows.Count
iCount = 4
If iCount > iLines Then
Stop
End If
While iCount <= iLines
If (Cells(iCount, 1).Value <> "X") And (IsEmpty(Cells(iCount, 3))) Then
Current_Endpoint = Endpoint & Cells(iCount, 2)
Set Json = ParseJson(xmlhttp.ResponseText)
For Each Item In Json("Resources")
Debug.Print Item("id")
Cells(iCount, 3).Value = Item("id")
Next Item
Set Json = Nothing
Set Item = Nothing
End If
iCount = iCount + 1
Wend
Dim items As New Collection, myitem As New Dictionary, amounts As New Dictionary, i As Integer
Dim Payload As String
Dim Line As Integer
Dim iLines As Integer
Dim iCount As Integer
iLines = Worksheets("Cash Advances").UsedRange.Rows.Count
iCount = 4
If iCount > iLines Then
Stop
End If
While iCount <= iLines
If (Cells(iCount, 1).Value <> "X") And (IsEmpty(Cells(iCount, 7))) Then
Set items = Nothing
Set myitem = Nothing
Set amounts = Nothing
amounts("currency") = Cells(iCount, 6).Value
amounts("amount") = Cells(iCount, 5).Value
myitem.Add ("amountRequested"), amounts
'myitem("comment") = "Comment Text"
myitem("name") = Cells(iCount, 4).Value
'myitem("purpose") = "Purpose text"
myitem("userId") = Cells(iCount, 3).Value
items.Add myitem
Payload = ConvertToJson(myitem, Whitespace:=2)
Debug.Print Payload
'Call Concur to create cash advance
Endpoint = Worksheets("Credentials").Cells(1, 2) & "/cashadvance/v4.1/cashadvances"
Cells(iCount, 7).Value = Blank
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
xmlhttp.Open "POST", Endpoint, False
xmlhttp.setRequestHeader "Content-Type", "application/json"
xmlhttp.setRequestHeader "Accept", "application/json"
xmlhttp.setRequestHeader "concur-correlationid", "ExcelVBA-Gpaparelli"
xmlhttp.setRequestHeader "Authorization", "Bearer " & Worksheets("Credentials").Cells(7, 2)
xmlhttp.setRequestHeader "Content-Length", "100"
xmlhttp.Send Payload
Debug.Print xmlhttp.ResponseText
Set Json = ParseJson(xmlhttp.ResponseText)
Debug.Print Json("cashAdvanceId")
Cells(iCount, 7).Value = Json("cashAdvanceId")
Set Json = Nothing
Set xmlhttp = Nothing
End If
iCount = iCount + 1
Wend
Dim items As New Collection, myitem As New Dictionary, amounts As New Dictionary, i As Integer
Dim Payload As String
.....
Set items = Nothing
Set myitem = Nothing
Set amounts = Nothing
amounts("currency") = Cells(iCount, 6).Value
amounts("amount") = Cells(iCount, 5).Value
myitem.Add ("amountRequested"), amounts
'myitem("comment") = "Comment Text"
myitem("name") = Cells(iCount, 4).Value
'myitem("purpose") = "Purpose text"
myitem("userId") = Cells(iCount, 3).Value
items.Add myitem
Payload = ConvertToJson(myitem, Whitespace:=2)
{
"amountRequested": {
"currency": "USD",
"amount": "10"
},
"comment": "This cash advance was issued by API",
"name": "Cash advance API 1",
"purpose": "Cash advance via API",
"userId": "dc6cd529-bf69-4a93-ace9-XXXXXXXXXX"
}
Dim items As New Collection, myitem As New Dictionary, i As Integer
Dim Payload As String
Dim Line As Integer
Dim iLines As Integer
Dim iCount As Integer
Endpoint = Worksheets("Credentials").Cells(1, 2) & "/cashadvance/v4.1/cashadvances/"
iLines = Worksheets("Cash Advances").UsedRange.Rows.Count
iCount = 4
If iCount > iLines Then
Stop
End If
While iCount <= iLines
If (Cells(iCount, 1).Value <> "X") And (IsEmpty(Cells(iCount, 9))) Then
Set myitem = Nothing
'myitem("comment") = "Comment Text"
myitem("exchangeRate") = Cells(iCount, 8).Value
'items.Add myitem
Payload = ConvertToJson(myitem, Whitespace:=2)
Debug.Print Payload
'Call Concur to issue cash advance
Current_Endpoint = Endpoint & Cells(iCount, 7).Value & "/issue"
Cells(iCount, 9).Value = Blank
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
xmlhttp.Open "POST", Current_Endpoint, False
xmlhttp.setRequestHeader "Content-Type", "application/json"
xmlhttp.setRequestHeader "Accept", "application/json"
xmlhttp.setRequestHeader "concur-correlationid", "ExcelVBA-Gpaparelli"
xmlhttp.setRequestHeader "Authorization", "Bearer " & Worksheets("Credentials").Cells(7, 2)
xmlhttp.setRequestHeader "Content-Length", "100"
xmlhttp.Send Payload
Debug.Print xmlhttp.ResponseText
Set Json = ParseJson(xmlhttp.ResponseText)
Debug.Print Json("status").Item("name")
Cells(iCount, 9).Value = Json("status").Item("name")
Set Json = Nothing
Set xmlhttp = Nothing
End If
iCount = iCount + 1
Wend
'Release object
Set xmlhttp = Nothing
{
"comment": "Issued via API",
"exchangeRate": 1.00000
}
You must be a registered user to add a comment. If you've already registered, sign in. Otherwise, register and sign in.
User | Count |
---|---|
8 | |
7 | |
7 | |
5 | |
4 | |
4 | |
4 | |
3 | |
3 | |
3 |