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使用Postman和PowerShell验证了PAT的正确功能。提到的两个工具都可以检索我期望的信息。
我使用的URL已通过网络浏览器边缘和铬片进行了验证。 下面的VBA代码依赖于在GitHub上发布的模块，称为JSONCONVERTER.BAS。 MS Excel版本是MS 365 App。
当前对我的要求的回应在下面 （由于允许的字符数量的限制，我仅分享了部分响应 响应：<!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; IE=10; IE=9; 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">
我说我无法绕过这个。 我希望你能帮我。
先前谢谢。
您不需要编码个人访问令牌（PAT）。而不是使用
BasicBearer
Authorization