First, you need to register your app on Azure Active Directory tenant. Then, is mandatory to provide a client secret for the application. You should at least grant access to User.Read for both Delegated permission and Application permission. You can do this in API permissions tab of the Azure AD tenant.
Then, here you go:
Sub AnyName()
Const clientId = "{cid}" 'this is application Id
Const tenantId = "{tid}"
Const clientSecret = "{cs}"
Const userPrincipalName = "{upn}"
Debug.Print GetUserProfile(GetToken(clientId, tenantId, clientSecret), userPrincipalName)
End Sub
Public Function GetToken(clientId As String, tenantId As String, clientSecret As String) As String
Dim objPost As Object
Dim urltoken As String
Const graphResource = "https://graph.microsoft.com"
Set objPost = CreateObject("MSXML2.XMLHTTP")
urltoken = "https://login.microsoftonline.com/" & tenantId & "/oauth2/token"
objPost.Open "POST", urltoken, False
objPost.Send ("grant_type=client_credentials&client_id=" & clientId & "&client_secret=" & clientSecret & "&resource=" & graphResource)
If objPost.ReadyState = 4 And objPost.Status = 200 Then
GetToken = ReadSimpleJson(objPost.ResponseText, "access_token")
Else
MsgBox "Error" & vbNewLine & "Ready state: " & objPost.ReadyState & _
vbNewLine & "HTTP request status: " & objPost.Status
End If
Set objPost = Nothing
End Function
Public Function ReadSimpleJson(jsonString As String, labelValue As String) As String
Dim sSplitJson() As String
Dim j As Integer
Dim sSplit() As String
jsonString = Replace(jsonString, "{", "")
jsonString = Replace(jsonString, "}", "")
sSplitJson = Split(jsonString, ",")
For j = 0 To UBound(sSplitJson)
sSplit = Split(sSplitJson(j), """:""")
If Replace(sSplit(LBound(sSplit)), """", "") = labelValue Then
ReadSimpleJson = Replace(sSplit(UBound(sSplit)), """", "")
End If
Next j
End Function
Public Function GetUserProfile(accessToken As String, userId As String) As String
Dim objPost As Object
Dim urlgraph As String
Set objPost = CreateObject("MSXML2.XMLHTTP")
urlgraph = "https://graph.microsoft.com/v1.0/users/" & userId 'or userPrincipalName
objPost.Open "GET", urlgraph, False
objPost.SetRequestHeader "Authorization", "Bearer " & accessToken
objPost.Send
If objPost.ReadyState = 4 And objPost.Status = 200 Then
GetUserProfile = objPost.ResponseText
Else
MsgBox "Error" & vbNewLine & "Ready state: " & objPost.ReadyState & _
vbNewLine & "HTTP request status: " & objPost.Status
End If
Set objPost = Nothing
End Function
See Graph Explorer | Try Microsoft Graph APIs - Microsoft Graph for other request addresses.
