VBAにてGraph APIによる、SharePointリスト情報の取得サンプル例

Option Explicit

' ==========================================
' 設定値（確定している値を固定しています）
' ==========================================
Private Const TENANT_ID As String = "●●●●●●●●●●●●●●●●●●●●●●●●●●●"
Private Const CLIENT_ID As String = "●●●●●●●●●●●●●●●●●●●●●●●●●●●"
Private Const SECRET_VALUE As String = "●●●●●●●●●●●●●●●●●●●●●●●●●●●"

' 環境情報
Private Const SHAREPOINT_HOST As String = "ms365d1975.sharepoint.com"
Private Const SITE_PATH As String = "/sites/2025Dev"
Private Const LIST_NAME As String = "FFF"

'''

''' メイン処理：Graph API経由でリスト「FFF」の正確なアイテム数をカウントする
'''

Public Sub GetSharePointListItemCount()
Dim accessToken As String
Dim itemCount As Long

' 1. Microsoft Graph用のアクセストークンを取得
accessToken = FetchGraphToken()
If accessToken = "" Then
    MsgBox "アクセストークンの取得に失敗しました。", vbCritical
    Exit Sub
End If

' 2. 改良されたカウントロジックで正確に計測
itemCount = FetchItemCountViaGraph(accessToken)

' 3. 結果の表示
If itemCount >= 0 Then
    MsgBox "リスト 「" & LIST_NAME & "」 の現在のアイテム数は " & itemCount & " 件です。", vbInformation
End If

End Sub

Private Function FetchGraphToken() As String
Dim http As MSXML2.XMLHTTP60
Dim tokenUrl As String
Dim requestBody As String
Dim responseText As String

Set http = New MSXML2.XMLHTTP60
tokenUrl = "https://login.microsoftonline.com/" & TENANT_ID & "/oauth2/v2.0/token"

requestBody = "grant_type=client_credentials" & _
              "&client_id=" & CLIENT_ID & _
              "&client_secret=" & WorksheetFunction.EncodeURL(SECRET_VALUE) & _
              "&scope=https://graph.microsoft.com/.default"
              
With http
    .Open "POST", tokenUrl, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .send requestBody
    responseText = .responseText
    
    If .Status = 200 Then
        Dim startPos As Long, endPos As Long
        startPos = InStr(responseText, """access_token"":""")
        If startPos > 0 Then
            startPos = startPos + Len("""access_token"":""")
            endPos = InStr(startPos, responseText, """")
            FetchGraphToken = Mid(responseText, startPos, endPos - startPos)
        End If
    End If
End With
Set http = Nothing

End Function

Private Function FetchItemCountViaGraph(ByVal accessToken As String) As Long
Dim http As MSXML2.XMLHTTP60
Dim apiUrl As String
Dim responseText As String

Set http = New MSXML2.XMLHTTP60
FetchItemCountViaGraph = -1

apiUrl = "https://graph.microsoft.com/v1.0/sites/" & SHAREPOINT_HOST & ":" & SITE_PATH & ":/lists/" & LIST_NAME & "/items"

With http
    .Open "GET", apiUrl, False
    .setRequestHeader "Authorization", "Bearer " & accessToken
    .setRequestHeader "Accept", "application/json"
    .send
    
    responseText = .responseText
    
    If .Status = 200 Then
        ' ★改善ポイント：関係ないメタデータの"id"を拾わないよう、
        ' アイテム1件ごとの開始マークである "contentType": 構造の出現数をカウントします。
        Dim searchStr As String
        searchStr = """contentType"":"
        
        Dim count As Long
        Dim pos As Long
        
        count = 0
        pos = InStr(responseText, searchStr)
        
        Do While pos > 0
            count = count + 1
            pos = InStr(pos + Len(searchStr), responseText, searchStr)
        Loop
        
        FetchItemCountViaGraph = count
    Else
        MsgBox "エラーが発生しました。" & vbCrLf & _
               "ステータス: " & .Status & vbCrLf & _
               "原因: " & responseText, vbCritical
    End If
End With
Set http = Nothing

End Function