【VBA】OneDriveの1階層目～5階層目までのデータを根こそぎ一覧化する

2023年7月9日 14:13

以前の記事の応用編です。
以前の記事：【VBA】Microsoft Graph APIを使って、OneDriveのアイテム一覧を取得する｜地獄の油揚げ (note.com)

今回は、OneDriveのRootフォルダ以下5階層目までのアイテム情報を根こそぎ取得し、一覧化します。

OneDriveのRootフォルダを第1階層と考えたとき、その下の子フォルダが第2階層、孫フォルダが第3階層…といった様に階層構造が形成されているかと思います。
任意の階層（本サンプルでは第5層目）を指定することで、その階層までのフォルダ・アイテム情報を全て取得し、Excelシートへ書き出しています。

Private Sub Get_OneDrive_Items()
   '１．AzureAD 各設定値
    Const TenantID = "h23409d4-kaer-46h3-93g4g5g58509"
    Const ClientID = "g5kj8839-ffu5-85k9-4hv6-uunnf87gf6r4"
    Const Scope = "Sites.ReadWrite.All  '「openid」「Sites.ReadWrite.All」「User.ReadWrite」"
    Const RedirectURL = "https://www.google.com"
    Const Auth_EndPoint = "https://login.microsoftonline.com/" & TenantID & "/oauth2/v2.0/authorize"  'OAuth 2.0の承認エンドポイント(v2)
    Const Token_EndPoint = "https://login.microsoftonline.com/" & TenantID & "oauth2/v2.0/token"  'OAuth 2.0トークンエンドポイント(v2)
    
    '２．アクセスコード取得
    Dim Param As String
    Param = "response_type=code" & _
                    "&client_id=" & ClientID & _
                    "&scope=" & Scope & _
                    "&redirect_uri" & RedirectURL
    Dim Req As Object 'XMLHTTP60
    Dim Response As String
    Dim S As Integer
    Dim E As Integer
    Dim code As String
    Set Req = CreateObject("MSXML2.XMLHTTP") '=New XMLHTTP60
    Req.Open "GET", Auth_EndPoint & "?" & Param, False
    Req.send
    Response = Req.responsetext
    S = InStr(Response, "code=")
    E = InStr(S + 5, Response, "&session")
    code = Mid(Response, S + 5, E - S - 5)
    
    '３．アクセスコードを使ってトークン取得
    Dim Req As Object 'XMLHTTP60
    Dim AccessToken As String
    Set Req = CreateObject("MSXML2.XMLHTTP") '=New XMLHTTP60
    Param = "grant_type=authorization_code" & _
                    "&response_type=code" & _
                    "&client_id=" & ClientID & _
                    "&scope=" & Scope & _
                    "&redirect_uri=" & RedirectURL & _
                    "&code=" & code
    Req.Open "POST", Token_EndPoint, False
    Req.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    Req.send Param
    Response = Req.responsetext
    If InStr(Response, "AADSTS54005") > 0 Then '低確率で出るエラー
        Debug.Print "トークンエンドポイントのレスポンスが正常に受信出来ませんでした。"
        MsgBox "OAuth2 認証コードは既に引き換え済みです。" & vbCrLf & "暫く経ってから、もう一度試してください。"
        End
    End If
    Dim Json As Dictionary 'Object
    Set Json = JsonConverter.ParseJson(Response)
    AccessToken = Json("access_token")
    Set Json = Nothing
    
    '４．OneDrive内のItem一覧を取得する
    Const UserID = "xxxxxxxxxxx@xxxxx.com"
    Dim Cnt As Integer '階層カウンター
    Dim asheet As Worksheet
    Dim target As String
    Dim Items() As Variant 'Item一覧を格納するための二次元配列
    Dim LastRow As Long
    Set asheet = Worksheet("Sheet1")
    Application.ScreenUpdating = False
    Cnt = 1
    Do
        Select Case Cnt
        Case 1 '1階層目（Rootフォルダのとき）
            target = UserID & "/drive/root/children"
            Items = Get_ItemsArray(target, Cnt, AccessToken)   'Get_ItemsArrayプロシージャを呼び出して、戻り値として二次元配列(アイテム情報)を受け取る
            LastRow = asheet.Cells(Rows.Count, 1).End(elup).Row
            Sheet.Range("A5", "E" & LastRow).Clear
            Selection.Rows.ClearOutline 'グループ化ボタンをクリア
            With asheet.Range("A5").Resize(UBound(Items), 5)
                .value = Items()
                .Borders.LineStyle = xlContinuous
                .Interior.Color = RGB(222, 164, 0) '濃い黄色
            End With
        Case Else '2階層目以降（子フォルダよりも深い階層のとき）
            Dim DataValue() As Variant
            Dim ChildCnt As Long
            Dim n As Long
            LastRow = asheet.Cells(Rows.Count, 1).End(xlUp).Row
            DataValue = Range("C5:E" & LastRow).value 'D列・E列の値を二次元配列DataCalueへ格納。一次元目が行数、二次元目の１がC列の値、二次元目の２がD列の値、３がE列の値
            For n = LBound(DataValue) To UBound(DataValue)
                ChildCnt = ChildCnt + DataValue(n, 2)
            Next
            Dim x As Long
            Dim num As Long
            For x = 5 To LastRow + ChildCnt - 5 '5行目～最終行（子Itemsを全て行挿入したときの最終行）を処理
                num = x - 4
                If DataValue(num, 2) = 0 Then '空フォルダのとき何もしない
                ElseIf DataValue(num, 2) <> "" And DataValue(num, 3) = Cnt - 1 Then 'Cnt階層の親階層（＝取得したい階層）かつ、中身があるフォルダのとき
                    target = UserID & "/drive/items/" & DataValue(num, 1) & "/children"
                    Items = Get_ItemsArray(target, Cnt, AccessToken)
                    asheet.Range(x + 1 & ":" & x + UBound(Items)).Insert '書き出す分だけ行挿入
                    With asheet.Range("A" & x + 1).Resize(UBound(Items), 5)
                        .value = Items()
                        .Borders.LineStyle = xlContinuous
                        If Cnt = 2 Then .Interior.Color = RGB(255, 206, 51) '黄色
                        If Cnt = 3 Then .Interior.Color = RGB(255, 230, 151) '薄い黄色
                        If Cnt = 4 Then .Interior.Color = RGB(255, 245, 213) '更に薄い黄色
                        If Cnt = 5 Then .Interior.Color = RGB(255, 255, 255) '白
                    End With
                    asheet.Range(x + 1 & ":" & x + UBound(Items)).Group
                    LastRow = asheet.Cells(Rows.Count, 1).End(xlUp).Row
                    DataValue = Range("C5:E" & LastRow).value ' 行挿入したら、二次元配列DataValueも再設定
                    x = x + UBound(Items)
                End If
                If x >= LastRow Then Exit For
            Next x
        End Select
        Cnt = Cnt + 1 'Cnt（階層カウンター）を１つ増やす
'    LoopWhile Cnt < 3 'Root、子の2階層分までループする
'    LoopWhile Cnt < 4 'Root、子、孫の3階層分までループする
'    LoopWhile Cnt < 5 'Root、子、孫、ひ孫の4階層分までループする
    LoopWhile Cnt < 6 'Root、子、孫、ひ孫、ひひ孫の5階層分までループする

    asheet.Outline.ShowLevels rowllevels:=1 'グループ化された行を全て折りたたむ
    asheet.Outline.SummaryRow = xlAbove 'グループ化マークを行の上側に付ける
    Application.ScreenUpdating = True
    asheet.Range("A4:E4") = Array("名前", "サイズ（KB)", "タグ名", "子Itemの数", "階層")
    asheet.Columns("A:E").AutoFit
    
    End Sub
    
    
    '受け取ったフォルダ内のJSONデータを取得し、必要な情報を二次元配列に格納して返す
Private Function Get_ItemsArray(ByVal target As String, ByVal Cnt As Integer, ByVal token As String) As Variant
    Dim Req As Object 'XMLHTTP60
    Dim URL As String
    Dim Json As Dictionary
    Dim value As Dictonary
    URL = "https://graph.microsoft.com/v1.0/users/" & target
    Set Req = CreateObject("MSXML2.XMLHTTP") ' =New XMLHTTP60
    Req.Open "GET", URL, False
    Req.setRequestHeader "Authorization", "Bearer " & token
    Req.send
    Response = Req.responsetext
    Set Req = Nothing
    Set Json = JsonConverter.ParseJson(Response)
    ReDim Items(Json("value").Count, 4)
    i = 0
    For Each value In Json("value")
        Items(i, 0) = value("name")
        Items(i, 1) = value("size")
        Items(i, 2) = Mid(value("eTag"), 3, 36) 'eTagは36文字固定のためこれでOK　\w{8}-\w{4}-\w{4}-\w{4}-\w{12}$
        On Error Resume Next 'Itemがファイルのとき（フォルダで無い時）エラー発生するため
        Items(i, 3) = value("folder")("childcount") 'value("folder")(1)
        On Error GoTo 0
        Items(i, 4) = Cnt
        i = i + 1
    Next
    Set Json = Nothing
    Get_ItemsArray = Items
End Function

１．～３．までの処理は、前回記事と同様なので割愛。
４．のところも、基本的には前回記事とやっていることは同じです。
Microsoft Graph APIを使ってOneDrive内のアイテム情報を取得し二次元配列に格納する処理の部分を、サブルーチン（Get＿ItemsArrayファンクションプロシージャ）に切り分けましたが、それ以外は大体一緒です。）

大きな流れとしては
・承認エンドポイントへHTTPリクエストして認証コードを取得。
・トークンエンドポイントへHTTPリクエストしてトークンを取得。
・Rootフォルダのアイテム一覧をExcelシートへ出力。【第1階層の処理】
・子フォルダのアイテム数の分だけ、Excelシートの行を挿入。
　子フォルダのアイテム一覧をExcelシートへ出力
　次の行へ処理を移し、それが子フォルダであれば同様に行挿入＆出力。
　全ての子フォルダに対して処理を行う。【第2階層の処理】
・孫フォルダのアイテムの数だけ、…（以下同様）【第3階層の処理】
・ひ孫フォルダのアイテムの数だけ、…（以下同様）【第4階層の処理】
これらを、任意の階層分（変数Cnt回分）繰り返す。

処理内容は単純ですが、コードが冗長になっていまいました。
補足情報は、コード内にコメントアウトして載せてあります。
もっと効率的な書き方があるかもしれませんが、とりあえず動くのでこれで良しとします。
因みに第5階層までを根こそぎ取得する場合、私の職場環境では5分くらい掛かりました（笑）
コーヒーでも飲んで気長に待ちましょうか。。

この記事が気に入ったらサポートをしてみませんか？