【pleasanter/VBA】エクスポート⑨汎用ツールを作ってみた

エクセルVBAでプリザンターから情報取得、シリーズ。第9回です。

今回は汎用ツールを作ってみました。

こちらのサイトを参考とさせていただいています。はーなるほど、と目からうろこ。ありがとうございました。
https://qiita.com/m-isik/items/0abfd51a22587bed2e47

2023.9.10.追記
こちらのサイトの汎用ツールは簡易版です。完全版はこちらの記事をご参照ください。

１．使用するエクセル
２．コード
３．最後に
４．参考記事

１．使用するエクセル

シートを二つ用意します。

１シート目：コマンドシート
APIキーやサイトID、出力項目を設定します。

２シート目:出力シート
このシートに書き出しします。

イメージ
APIキーとサイトIDの入力欄、出力項目を設定する欄を設けています。

コマンドシートの出力項目の指定個所は「TiTle」や「Class」をプルダウンで選択する様式にしています（データの入力規則を使用）。Classなどについては隣の列に「A～Z」を選択するようにしています。
2023.9.16追記：出力項目のリストでOwnerが２つめと7つ目に重複しています。一つでいいです。

２．コード

※jsonConverterを利用しています。
【EXCEL VBA】VBAでJSONを利用したい
※httpRequest.Open の部分のURLは環境に合わせて設定してください。
※分類項目等はA～Zまでしか対応していません。
※Microsoft Scripting Runtime を参照設定しています。
※ページサイズ以上のデータ取得は対応していません。ページサイズ以上のデータを取得する必要がある場合は、こちらのコードを参照いただくか、こちらの記事等を参照いただきoffset処理を追加してください。

'参照設定：Microsoft Scripting Runtime

Sub pleasanter_export_hanyou()
    On Error GoTo ErrHandler
    Dim msg As String
    Application.ScreenUpdating = False
    
    '++++++ 基本情報設定 ++++++
    'コマンドシート
    Dim wsCom As Worksheet
    Const RowStartKoumoku As Long = 6
    Const ColKoumoku1 As Long = 2
    Const ColKoumoku2 As Long = 3
    Set wsCom = Worksheets("コマンド")
    '出力シート
    Dim wsExport As Worksheet
    Set wsExport = Worksheets("出力")
    Const RowStartE As Long = 2         '出力開始行
    '出力シートクリア
    wsExport.Cells.Clear
    
    '++++++ コマンドシートから取得条件を取得 ++++++
    Dim myApikey As String
    Dim siteId As String
    With wsCom
        myApikey = Trim(.Range("C2").Value) 'APIキー
        siteId = Trim(.Range("C3").Value)   'サイトID
    End With
    '値のチェック
    If myApikey = "" Then
        msg = "APIキーを入力してください" & vbCrLf & "処理を中断します"
        GoTo ErrHandler
    ElseIf Not IsNumeric(siteId) Or siteId = "" Then
        msg = "サイトIDが正しくありません" & vbCrLf & "処理を中断します"
        GoTo ErrHandler
    End If
    
    '出力項目を配列columnNamesに代入
    Dim columnNames() As String     '項目名を入れる配列
    Dim i As Long, rowEnd As Long
    Dim idx As Long: idx = 1
    Dim buf As String
    With wsCom
        rowEnd = .Cells(.Rows.Count, ColKoumoku1).End(xlUp).Row
        For i = RowStartKoumoku To rowEnd
            buf = .Cells(i, ColKoumoku1).Value & .Cells(i, ColKoumoku2).Value
            If buf <> "" Then
                ReDim Preserve columnNames(1 To idx)
                columnNames(idx) = buf
                idx = idx + 1
            End If
        Next i
    End With
             
    '++++++ プリザンターから情報取得 ++++++
    Dim jsonRequest     As Dictionary
    Dim parseResponse   As Dictionary
    Dim httpRequest     As Object
    
    Set jsonRequest = New Dictionary
    
    jsonRequest.Add "ApiVersion", "1.1"
    jsonRequest.Add "ApiKey", myApikey
    jsonRequest.Add "View", New Dictionary
    
    Set httpRequest = CreateObject("msxml2.xmlhttp")
    
    httpRequest.Open "POST", "http://localhost/api/items/" & siteId & "/get"    '※siteIdの前の部分は変更要
    httpRequest.setRequestHeader "Content-Type", "application/json;charset=utf-8"
    
    httpRequest.send JsonConverter.ConvertToJson(jsonRequest)
    
    Do While httpRequest.readyState < 4
        DoEvents
    Loop

    Set parseResponse = JsonConverter.ParseJson(httpRequest.responseText)
    
    If parseResponse("Response")("Data").Count <= 0 Then
        MsgBox "出力データがありません" & vbCrLf & "処理を中断します"
        Exit Sub
    End If
    
    Dim responseData As Variant
    Dim prefix As String, suffix As String
    
    Dim vRow As Long: vRow = RowStartE
    With wsExport
        '項目名出力
        For idx = LBound(columnNames) To UBound(columnNames)
            .Cells(1, idx).Value = columnNames(idx)
        Next idx
        'データ出力
        For Each responseData In parseResponse("Response")("Data")
            For idx = LBound(columnNames) To UBound(columnNames)
                
                If InStr(columnNames(idx), "Class") > 0 _
                    Or InStr(columnNames(idx), "Num") > 0 _
                    Or InStr(columnNames(idx), "Check") > 0 _
                    Or InStr(columnNames(idx), "Description") > 0 Then
                'クラス、数値等アルファベットが最後につく項目の処理
                        prefix = Left(columnNames(idx), Len(columnNames(idx)) - 1)
                        suffix = Right(columnNames(idx), 1)
                        .Cells(vRow, idx).Value = responseData(prefix & "Hash")(prefix & suffix)
                ElseIf InStr(columnNames(idx), "Date") > 0 Then
                '日付の場合の処理。文字列日付をシリアル値に変換する
                    suffix = Right(columnNames(idx), 1)
                    .Cells(vRow, idx).Value = strDateToDateTime(responseData("DateHash")("Date" & suffix))
                ElseIf InStr(columnNames(idx), "Time") > 0 Then
                'Date以外の日付の場合の処理。文字列日付をシリアル値に変換する
                    .Cells(vRow, idx).Value = strDateToDateTime(responseData(columnNames(idx)))
                Else
                'クラス、数値等アルファベットが最後につく項目以外の処理
                    .Cells(vRow, idx).Value = responseData(columnNames(idx))
                End If
            Next idx
            vRow = vRow + 1
        Next
    End With
    
    Application.ScreenUpdating = True
    MsgBox "出力完了"
    wsExport.Activate
    Exit Sub
ErrHandler:
    If msg <> "" Then
        MsgBox msg
    Else
        MsgBox "エラーが発生しました" & vbCrLf & "処理を中断します" & _
                "エラー№" & Err.Number & ":" & Err.Description
    End If
    Application.ScreenUpdating = True
End Sub

Private Function strDateToDateTime(ByVal str As String) As Variant
    '日付時刻
    If Val(Left(str, 4)) < 1900 Then
        strDateToDateTime = ""
    Else
        strDateToDateTime = CDate(Replace(str, "T", " "))
    End If
End Function

特に詳しく解説はしませんが、分類項目などの出力個所

 prefix = Left(columnNames(idx), Len(columnNames(idx)) - 1)
 suffix = Right(columnNames(idx), 1)
 .Cells(vRow, idx).Value = responseData(prefix & "Hash")(prefix & suffix)

たとえば「ClassA」を指定していた場合、prefixには「Class」が入り、suffixには「A」が入ります。
responseData(prefix & “Hash”)(prefix & suffix)　は
responseData(“ClassHash”)(“ClassA”)
となります。