【pleasanter/VBA】エクスポート⑩汎用ツール完全版

エクセルVBAでプリザンターから情報取得、シリーズ。第10回です。今回でこのシリーズは終わりです。

前回、vbaでエクスポートの汎用ツールを作成しました。今回は、その増強版を作成してみました。
何が違うかというと、
・offset処理を追加（ページサイズ以上のデータも大丈夫）
・日付項目に限り、取得条件を設定できるようにした（1項目のみ設定可。省略も可）
・ワークシートへの書き出しのスピードアップのため配列を利用
・分類項目などのサフィックスがA～Z以外も対応可（試すことができないので、多分）

１．コード
２．エクセルの仕様
３．最後に
４．参考とさせていただいた記事
５．プリザンザンターVBAエクスポートシリーズ　リンク

１．コード

いきなりですが、コードです。へなちょこテストサイトでしか試していないので、変なところあったらごめんなさいですが、責任はとれませんので、ご了承ください。。。
ご指摘ありましたら、コメントにて教えていただけたらと思います。
※のホスト名のところは環境に合わせて設定してください。
※jsonConverterを利用しています。詳しくはこちらの記事等を参照してください。
https://vba-labo.rs-techdev.com/archives/1401
※分類項目等はA～Zまでしか対応していません。
※Microsoft Scripting Runtime を参照設定しています。

'参照設定：Microsoft Scripting Runtime

Type columnname
    koumoku As String
    suffix As String
End Type

Sub pleasanter_export_hanyou2()
    On Error GoTo ErrHandler
    Dim msg As String
    Application.ScreenUpdating = False
    
    '++++++++++++++++++++++++++++++++++++++++++++
    '    基本情報設定
    '++++++++++++++++++++++++++++++++++++++++++++
    'プリザンター情報
    'ホスト名※
    Const serverName As String = "http://localhost/api/items/"
    
    'コマンドシート
    Dim wsCom As Worksheet
    Const RowStartKoumoku As Long = 6           '取得項目入力開始行
    Const ColKoumoku As Long = 2                '項目名の列
    Const ColSuffix As Long = 3                 'サフィックスの列
    Const StrRngDateKoumoku As String = "G6"    '日付条件項目名のセル位置
    Const StrRngDateSatrt As String = "G7"      '日付条件 開始日 のセル位置
    Const StrRngDateEnd As String = "G8"        '日付条件 終了日 のセル位置
    Set wsCom = Worksheets("コマンド")
    
    '出力シート
    Dim wsExport As Worksheet
    Const RowStartE As Long = 2         '出力開始行
    Set wsExport = Worksheets("出力")
    
    '++++++++++++++++++++++++++++++++++++++++++++
    '   コマンドシートから取得条件を取得
    '++++++++++++++++++++++++++++++++++++++++++++
    Dim myApikey As String, 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
    
    '出力項目を配列colNamesに代入
    Dim colNames() As columnname     '項目名を入れる配列
    Dim i As Long, rowEnd As Long
    Dim idx As Long: idx = 1
    With wsCom
        rowEnd = .Cells(.Rows.Count, ColKoumoku).End(xlUp).Row
        If rowEnd < RowStartKoumoku Then
            msg = "出力項目を指定してください"
            GoTo ErrHandler
        End If
        For i = RowStartKoumoku To rowEnd
            If .Cells(i, ColKoumoku).Value <> "" Then
                ReDim Preserve colNames(1 To idx)
                colNames(idx).koumoku = .Cells(i, ColKoumoku).Value
                colNames(idx).suffix = .Cells(i, ColSuffix).Value
                idx = idx + 1
            End If
        Next i
    End With
    
    '日付条件作成
    Dim joukenDateKoumoku As String, strDate As String
    With wsCom
        '条件指定日付項目に項目名がセットされている場合のみ日付条件作成
        If .Range(StrRngDateKoumoku).Value <> "" Then
            '条件の日付項目
            joukenDateKoumoku = .Range(StrRngDateKoumoku).Value
            '日付条件文字列作成
            strDate = getDateJouken(.Range(StrRngDateSatrt).Value, .Range(StrRngDateEnd).Value)
        End If
    End With
    
    '++++++++++++++++++++++++++++++++++++++++++++
    '    前処理
    '++++++++++++++++++++++++++++++++++++++++++++
    '出力シートクリア,項目名出力
    wsExport.Cells.Clear
    With wsExport
        '項目名出力
        For idx = LBound(colNames) To UBound(colNames)
            .Cells(1, idx).Value = colNames(idx).koumoku & colNames(idx).suffix
        Next idx
    End With
    Dim printRow As Long: printRow = RowStartE

    '++++++++++++++++++++++++++++++++++++++++++++
    '   プリザンターから情報取得
    '++++++++++++++++++++++++++++++++++++++++++++
    Dim arrData() As Variant            '取得データ一時格納用配列
    
    Dim jsonRequest     As Dictionary
    Dim parseResponse   As Dictionary
    Dim httpRequest     As Object
    
    Dim offsetCnt As Long: offsetCnt = 0
    Dim endFlg As Boolean: endFlg = False
    
    Do Until endFlg = True
    
        Set jsonRequest = New Dictionary
        
        jsonRequest.Add "ApiVersion", "1.1"
        jsonRequest.Add "ApiKey", myApikey
        jsonRequest.Add "Offset", offsetCnt
        
        '日付条件がある場合のみフィルタ作成
        If strDate <> "" Then
            jsonRequest.Add "View", New Dictionary
            jsonRequest("View").Add "ColumnFilterHash", New Dictionary
            jsonRequest("View")("ColumnFilterHash").Add joukenDateKoumoku, strDate
        End If
        
        Set httpRequest = CreateObject("msxml2.xmlhttp")
        
        httpRequest.Open "POST", serverName & siteId & "/get"
        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
        
        If offsetCnt + parseResponse("Response")("PageSize") >= parseResponse("Response")("TotalCount") Then
            endFlg = True
        Else
            offsetCnt = offsetCnt + parseResponse("Response")("PageSize")
        End If
        
        Dim responseData As Variant
        Dim idxRow As Long, idxCol As Long
        idxRow = 1
        
        'データ蓄積＝＞arrData
        ReDim arrData(1 To parseResponse("Response")("PageSize"), 1 To UBound(colNames))
        
        For Each responseData In parseResponse("Response")("Data")
            For idxCol = LBound(colNames) To UBound(colNames)
                
                With colNames(idxCol)
                    If .koumoku = "Class" Or .koumoku = "Num" Or .koumoku = "Check" Or .koumoku = "Description" Then
                        'クラス、数値等アルファベットが最後につく項目の処理
                        arrData(idxRow, idxCol) = responseData(.koumoku & "Hash")(.koumoku & .suffix)
                            
                    ElseIf .koumoku = "Date" Then
                        '日付の場合の処理。文字列日付をシリアル値に変換する
                        arrData(idxRow, idxCol) = strDateToDateTime(responseData("DateHash")("Date" & .suffix))
                        
                    ElseIf InStr(.koumoku, "Time") > 0 Then
                        'Date以外の日付の場合の処理。文字列日付をシリアル値に変換する
                        arrData(idxRow, idxCol) = strDateToDateTime(responseData(.koumoku & .suffix))
                        
                    Else
                        'クラス、数値等アルファベットが最後につく項目以外の処理
                        arrData(idxRow, idxCol) = responseData(.koumoku & .suffix)
                        
                    End If
                End With
            Next idxCol
            idxRow = idxRow + 1
        Next
        
        'シートに出力
        With wsExport
            .Cells(printRow, 1).Resize(UBound(arrData), UBound(arrData, 2)).Value = arrData
        End With
        printRow = printRow + parseResponse("Response")("PageSize")
        
        Set jsonRequest = Nothing
        Set httpRequest = Nothing
        Set parseResponse = Nothing
        
    Loop
    
    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

Private Function getDateJouken(ByVal date1 As Variant, ByVal date2 As Variant) As String
    
    Dim dateStart As String, dateEnd As String
    Dim dateStartflg As Boolean, dateEndflg As Boolean
    
    '開始日
    If date1 <> "" and IsDate(date1) Then
        dateStart = Format(date1, "yyyy/mm/dd")
        dateStartflg = True
    End If
    '終了日
    If date2 <> "" and IsDate(date2) Then
        dateEnd = Format(date2, "yyyy/mm/dd")
        dateEndflg = True
    End If
    
    '日付条件文字列作成
    Dim strDate As String
    If dateStartflg = True And dateEndflg = True Then
        strDate = "[""" & dateStart & " 00:00:00," & dateEnd & " 23:59:59""]"
    ElseIf dateStartflg = True Then
        strDate = "[""" & dateStart & " 00:00:00,""]"
    ElseIf dateEndflg = True Then
        strDate = "[""," & dateEnd & " 23:59:59""]"
    End If
    
    getDateJouken = strDate
    
End Function

２．エクセルの仕様

Excelのコマンドシートのイメージです。

「出力項目」「サフィックス」「条件指定日付項目」は入力規則でリストから選択するようにしています。別シートにリストの内容を用意しています。

※2023.9.16追記。出力項目リストにOwnerが3行目と8行目でダブっています。どちらか一つだけで大丈夫です。ごめんなさい。

最近覚えたのですが、リストの参照範囲にしたいセル範囲に名前を定義しておいて、入力規則で定義した名前を使用して参照範囲を設定する方法は便利ですね。

ちなみにサフィックスの部分は非表示にしているD列にClass,Num,Date,Description,Checkの場合「サフィックス」と表示させ、INDIREDT関数と組み合わせてClass,Num,Date,Description,Checkが入力された場合のみ、A～Zのプルダウンを表示するようにしています。
そこまでしなくても Title A 等と指定しても、サフィックスは無視される仕様なのでそんなことしなくてもいいのですが。