excelvbaazure-devops

Authorization issue while trying to connect to Azure DevOps REST API with MS Excel VBA

I would like to retrieve information from Azure DevOps, with MS Excel VBA, via the Azure DevOps REST API. (Since all other logic is in the MS Excel workbook i have to stick to VBA)

With MS Excel VBA I can’t get around an authorization issue. I do use an Personal Access token (PAT), which I created in Azure DevOps for that purpose.

The VBA code currently used is :

Sub GetADOIncrements()
    On Error GoTo ErrorHandler
    
    Dim http As Object
    Dim url As String
    Dim token As String
    Dim jsonResponse As String
    Dim json As Object
    Dim ws As Worksheet
    Dim i As Integer
    
    ' Set worksheet
    Set ws = ThisWorkbook.Sheets("Projects")
    ws.Cells.Clear
    
    ' Azure DevOps organisatie en API URL
    Dim organization As String
    organization = "OdinNB" ' Vervang door jouw organisatie
    project = "Odin/FT" ' Vervang door jouw project
    
    ' Azure DevOps REST API URL
    url = "https://dev.azure.com/" & organization & "/" & project & "/_apis/work/teamsettings/iterations?api-version=7.1"
    
    ' Personal Access Token (PAT)
    token = "somethingsecret" ' Vervang door jouw PAT
    
    ' Create HTTP request
    Set http = CreateObject("MSXML2.ServerXMLHTTP")
    http.Open "GET", url, False
    http.setRequestHeader "Authorization", "Basic " & Base64Encode(":" & token)
    http.setRequestHeader "Content-Type", "application/json"
    http.send
    
    ' Check for HTTP errors
    If http.Status <> 200 Then
        jsonResponse = http.responseText
        GoTo ErrorHandler
    End If
    
    ' Parse JSON response
    jsonResponse = http.responseText
    Set json = JsonConverter.ParseJson(jsonResponse)
    
    ' Write data to worksheet
    i = 1
    For Each iteration In json("value")
        ws.Cells(i, 1).Value = iteration("id")
        ws.Cells(i, 2).Value = iteration("name")
        ws.Cells(i, 3).Value = iteration("path")
        ws.Cells(i, 4).Value = iteration("attributes")("startDate")
        ws.Cells(i, 5).Value = iteration("attributes")("finishDate")
        i = i + 1
    Next iteration
    
    ' Format columns
    ws.Columns("A:E").AutoFit
    
    ' Exit subroutine
    Exit Sub
    
ErrorHandler:
    Dim errorMessage As String
    errorMessage = "Fout: " & Err.Number & " - " & Err.Description & vbCrLf & "Regel: " & Erl & vbCrLf & "Response: " & jsonResponse
    
    ' Write error message to cell B2 in "ErrorMessage" sheet
    Dim errorSheet As Worksheet
    On Error Resume Next
    Set errorSheet = ThisWorkbook.Sheets("ErrorMessage")
    If Not errorSheet Is Nothing Then
        errorSheet.Cells(2, 2).Value = errorMessage
    Else
        MsgBox "Het werkblad 'ErrorMessage' bestaat niet.", vbCritical
    End If
    On Error GoTo 0
    
    MsgBox errorMessage, vbCritical
    Resume Next
End Sub

Function Base64Encode(text As String) As String
    Dim arr() As Byte
    arr = StrConv(text, vbFromUnicode)
    Base64Encode = EncodeBase64(arr)
End Function

Function EncodeBase64(arr() As Byte) As String
    Dim xml As Object
    Set xml = CreateObject("MSXML2.DOMDocument")
    xml.LoadXML "<root />"
    xml.documentElement.dataType = "bin.base64"
    xml.documentElement.nodeTypedValue = arr
    EncodeBase64 = xml.documentElement.Text
End Function

I verified the correct functioning of the PAT by using Postman and Powershell. Both tools mentioned do retrieve the information I expected.

The URL I used I’ve verified with an web browsers Edge and Chrome. Below VBA code relies on an module published on Github, called JsonConverter.bas. The MS Excel version is an MS 365 app.

The current response on my request is below (I only shared an partial response due to the limitation of the number of characters allowed Response:

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">

<html lang="nl-NL">
<head><title>
    
            Azure DevOps Services | Sign In
        
</title><meta http-equiv="X-UA-Compatible" content="IE=11;&#32;IE=10;&#32;IE=9;&#32;IE=8" />
    <link rel="SHORTCUT ICON" href="/favicon.ico"/>

    <link data-bundlelength="516093" data-bundlename="commoncss" data-highcontrast="/_static/tfs/M251_20250210.1/_cssbundles/HighContrast/vss-bundle-commoncss-vgKIrce5KeykK4FMEhpmn7zyu-3J73Bx2KsJTMmi4ZaI=" data-includedstyles="jQueryUI-Modified;Core;Splitter;PivotView" href="/_static/tfs/M251_20250210.1/_cssbundles/Default/vss-bundle-commoncss-vuiSc9pHdDbcT8LzK_3fJ2kEsn4_fRqmPx_6IdU0oXHc=" rel="stylesheet" />
<link data-bundlelength="117396" data-bundlename="viewcss" data-highcontrast="/_static/tfs/M251_20250210.1/_cssbundles/HighContrast/vss-bundle-viewcss-vGUk8uw7JNxRjAw_tyNEzCFSNV6F4rpcB50TY_v1djOE=" data-includedstyles="VSS.Controls" href="/_static/tfs/M251_20250210.1/_cssbundles/Default/vss-bundle-viewcss-vKzCQ2wRcxozUbM0wmGy9QGeur1Tf6QGMY1-4Cznv5pQ=" rel="stylesheet" />

    <!--UxServices customizations -->
    
    <link href="/_static/tfs/M251_20250210.1/_content/Authentication.css" type="text/css" rel="stylesheet" />
    
</head>

<body class="platform">

As stated i can't get my head around this. I hope you can help me out.

Many thanks in advance.

Solution

  • You don't need to encode the Personal Access Token (PAT). Instead of using Basic authentication, try using Bearer authentication with the PAT directly as that in the Authorization header below.

    Sub GetADOIncrements()
    On Error GoTo ErrorHandler
    
    Dim http As Object
    Dim url As String
    Dim token As String
    Dim jsonResponse As String
    
    ' Azure DevOps Organization and API URL
    Dim organization As String
    Dim project As String
    
    organization = "YourAzureDevOpsOrgName" ' Replace with your organization
    project = "Odin/FT" ' Replace with your project/Team
    
    ' Construct API URL
    url = "https://dev.azure.com/" & organization & "/" & project & "/_apis/work/teamsettings/iterations?api-version=7.1"
    
    ' Personal Access Token (PAT)
    token = "xxxxxx" ' Replace with your PAT
    
    ' Print API URL
    Debug.Print "API URL: " & url
    
    ' Create HTTP request
    Set http = CreateObject("MSXML2.ServerXMLHTTP")
    http.Open "GET", url, False
    http.setRequestHeader "Authorization", "Bearer " & token
    http.setRequestHeader "Content-Type", "application/json"
    http.send
    
    ' Check for HTTP errors
    If http.Status <> 200 Then
        jsonResponse = http.responseText
        GoTo ErrorHandler
    End If
    
    ' Print the raw API response
    jsonResponse = http.responseText
    Debug.Print "Response: " & jsonResponse
    
    ' Exit subroutine
    Exit Sub
    
ErrorHandler:
    Debug.Print "Error: " & Err.Number & " - " & Err.Description
    Debug.Print "Response: " & jsonResponse
    MsgBox "Error: " & Err.Number & " - " & Err.Description, vbCritical
End Sub

    vba