PleasanterとExcelを接続してみた－応用編

はじめに

以前投稿した[こちら]の記事の応用編として、汎用的なエクセルツールとして、Pleasanterのテーブルを取得・登録できるものを作ってみました。

前提

• VBAでJsonを扱うため、[VBA-JSON]を利用しています。
• PleasatnerのAPIの扱いについては[マニュアル]を参考にしてください。

Excel画面

作成した画面は以下のとおり。（UIデザインセンスの無さはご勘弁）

テーブル取得用シート

取得対象のPleasanter、サイト、抽出条件、取得項目をエクセルから指定させることで、フレキシブルにいろいろな情報をPleasatnerから取得できるようにしました。

• B2セル：取得対象のPleasanterのサイトIDを設定
• B3セル：取得対象のPleasanterのUrlを設定
• 6行目：抽出条件とするColumnFilterHashに設定する項目名を必要な分だけ設定
• 7行目：抽出条件値を項目カラムに合わせて設定
• 22行目：ソートしたい場合、a（昇順）、d（降順）を設定
• 23行目：Pleasanterから取得したい項目を設定
• 24行目以降：Pleasanterから取得した項目が展開される
• 取得ボタン押下でPleasanterから項目を取得、クリアボタン押下で取得結果をクリア

テーブル登録用シート

こちらも、各種条件をエクセルから指定させるようにします。ただ、今回は１レコードずつの登録のみに対応。

• B2セル：登録対象のPleasanterのサイトIDを設定
• B3セル：登録対象のPleasanterのレコードIDを設定。未入力の場合新規作成する
• B6セル：登録結果を表示
• B7セル：登録後、登録したレコードのPleasanterへのリンクを設定
• 10行目：登録したいPleasanterの項目を必要な分だけ設定
• 11行目：登録する値を設定
• 登録ボタン押下でPleasanterに登録

サンプルコード

[こちら]からDLして、VBAにインポートしてみてください。
（ApiHttpControl.bas、ApiKeyControl.bas、ExcelControl.bas、MainControl.bas）

注意

• 以下参照設定が必要です。

  • Microsoft Scripting Runtime
  • Windows Script Host Object Model

• PleasanterにアクセスできるApiKeyを取得し、利用端末のユーザ環境変数に、変数名”ApiKey”にApiKeyの値を設定してください。
  

• (繰り返しになりますが)[VBA-JSON]もインポートしてください。

• 適当なシートに、前述の要素を用意してください。カラム位置を変更したい場合は、VBAも調整してください。

• 適当なシートから、ボタンやショートカットなどで、以下の関数を実行するように割り当ててください。

  • テーブル取得シート → テーブル取得メイン・アクティブシートクリア
  • テーブル登録シート → テーブル登録メイン

これできっとうまくいくはず。

簡単なソース解説

テーブル取得メイン処理

※主要な部分だけ抜粋

'実行前にシートクリア処理とかあるけど割愛

'アクティブシート名を取得
' → シートを増やしても、アクティブにしてから関数を実行すれば取得可
sheetName = ActiveSheet.Name

'リクエストのためのjson用Dictionaryを用意する
Set GetMultiRecordJson = New Dictionary
Set GetMultiRecordJson = SetApiKey(GetEnvironmentApiKey, GetMultiRecordJson)

'入力エリアに設定された条件値の数をEnd(xlToRight).Columnで取得する
'テーブル取得入力エリア
'　→　Enumでカラム情報を定義、エクセルレイアウトを変えたい場合は変更要
maxCol = Worksheets(sheetName).Cells(テーブル取得入力エリア.開始行, テーブル取得入力エリア.開始列).End(xlToRight).Column

'設定された条件値の分ループして、リクエストするjson用Dictionaryを生成する
'json用Dictionary生成は関数化
'　→　SetColumnFilterHash、SetColumnFilterHashItemなど、処理はApiHttpControl.bas参照
For j = 1 To maxCol

    If Worksheets(sheetName).Cells(テーブル取得入力エリア.開始行 + 1, j).Value <> "" Then 
        If filterFirst = True Then
            'フィルターがあれば初回だけ作る
            Set GetMultiRecordJson = SetView(GetMultiRecordJson)
            'フィルターがあれば初回だけ作る
            Set GetMultiRecordJson = SetColumnFilterHash(GetMultiRecordJson)
            filterFirst = False
        End If
        '関数にキーと値を渡してjson用Dictionaryに設定する
        Set GetMultiRecordJson = SetColumnFilterHashItem(Worksheets(sheetName).Cells(テーブル取得入力エリア.開始行, j).Value, _
                                                    Worksheets(sheetName).Cells(テーブル取得入力エリア.開始行 + 1, j).Value, _
                                                    GetMultiRecordJson)
    End If
Next j

'リクエスト用のURLを設定する
strUrl = Worksheets(sheetName).Cells(3, 2).Value & "/api/items/" & Worksheets(sheetName).Cells(2, 2).Value & "/get"

'HTTPリクエスト発行　→　ApiHttpControl.bas参照
'リクエスト発行時にVBA-JSONでDictionaryをJson形式にコンバート
Set objHTTP = HTTPリクエスト発行(strUrl, GetMultiRecordJson)

'レスポンスjsonをパース（VBA-JSON）
Set Parse = JsonConverter.ParseJson(objHTTP.responseText)

'取得件数をチェック、0件なら処理終了
If Parse("Response")("Data").count <= 0 Then
    Exit Sub
End If

'出力エリアに設定された出力カラムの数をEnd(xlToRight).Columnで取得する
'テーブル取得出力エリア
'　→　Enumでカラム情報を定義、エクセルレイアウトを変えたい場合は変更要
maxCol = Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, テーブル取得出力エリア.開始列).End(xlToRight).Column

ReDim Pj(Parse("Response")("Data").count - 1, maxCol)

i = 0
sortKey = 0

'取得データ件数分ループ
For Each DesStr In Parse("Response")("Data")
     
    '出力エリアに設定した出力カラム数分ループ
    For j = 0 To maxCol - 1
        
        Select Case True
        
        '項目種類ごとに編集
        Case InStr(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value, "Class")
            Pj(i, j) = DesStr("ClassHash")(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value)
        
        Case InStr(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value, "Num")
            Pj(i, j) = DesStr("NumHash")(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value)
        
        Case InStr(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value, "Date")
            Pj(i, j) = DesStr("DateHash")(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value)
        
        Case InStr(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value, "Check")
            Pj(i, j) = DesStr("CheckHash")(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value)
        
        Case InStr(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value, "Description")
            Pj(i, j) = DesStr("DescriptionHash")(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value)

        Case Else
            Pj(i, j) = DesStr(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行, j + 1).Value)
            
        End Select
        'ソートのための処理とかあるけどここでは割愛
    Next j        
     i = i + 1
Next

'エクセルに取得情報を展開
Worksheets(sheetName).Range(Worksheets(sheetName).Cells(テーブル取得出力エリア.開始行 + 1, テーブル取得出力エリア.開始列), _
                    Worksheets(sheetName).Cells(Parse("Response")("Data").count + テーブル取得出力エリア.開始行, maxCol)) = Pj

'実行後にソート処理とかあるけど割愛

テーブル登録メイン処理

※主要な部分だけ抜粋

'アクティブシート名を取得 
'→ シートを増やしても、アクティブにしてから関数を実行すれば取得可
sheetName = ActiveSheet.Name

'リクエストのためのjson用Dictionaryを用意する
Set CreateRecordJson = New Dictionary
Set CreateRecordJson = SetApiKey(GetEnvironmentApiKey, CreateRecordJson)

'入力エリアに設定された条件値の数をEnd(xlToRight).Columnで取得する
'テーブル登録入力エリア
'　→　Enumでカラム情報を定義、エクセルレイアウトを変えたい場合は変更要
maxCol = Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行, テーブル登録入力エリア.開始列).End(xlToRight).Column

'設定された条件値の分ループして、リクエストするjson用Dictionaryを生成する
'json用Dictionary生成は関数化
'　→　SetClassHash、SetClassHashItemなど、処理はApiHttpControl.bas参照
For j = 1 To maxCol

        Select Case True
        
        '項目種類ごとに編集する（Check項目には対応できていません！！）
        Case InStr(Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行, j).Value, "Class")
            If classHashFirst = True Then
                '初回だけ作る
                Set CreateRecordJson = SetClassHash(CreateRecordJson)
                classHashFirst = False
            End If
            
            Set CreateRecordJson = SetClassHashItem(Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行, j), _
                                                    Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行 + 1, j), _
                                                    CreateRecordJson)
        Case InStr(Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行, j + 1).Value, "Num")
            If numHashFirst = True Then
                '初回だけ作る
                Set CreateRecordJson = SetNumHash(CreateRecordJson)
                numHashFirst = False
            End If
            
            Set CreateRecordJson = SetNumHashItem(Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行, j), _
                                                    Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行 + 1, j), _
                                                    CreateRecordJson)
        Case InStr(Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行, j + 1).Value, "Date")
            If dateHashFirst = True Then
                '初回だけ作る
                Set CreateRecordJson = SetDateHash(CreateRecordJson)
                dateHashFirst = False
            End If
            
            Set CreateRecordJson = SetDateHashItem(Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行, j), _
                                                    Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行 + 1, j), _
                                                    CreateRecordJson)
        Case Else
            Set CreateRecordJson = SetItem(Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行, j), _
                                                    Worksheets(sheetName).Cells(テーブル登録入力エリア.開始行 + 1, j), _
                                                    CreateRecordJson)
        End Select
Next j

'URLを生成
If Worksheets(sheetName).Cells(3, 2).Value & Worksheets(sheetName).Cells(3, 2).Value = "" Then
'登録IDが無ければ新規
    strUrl = Worksheets(sheetName).Cells(4, 2).Value & "/api/items/" & Worksheets(sheetName).Cells(2, 2).Value & "/create"
Else
'存在したら更新
    strUrl = Worksheets(sheetName).Cells(4, 2).Value & "/api/items/" & Worksheets(sheetName).Cells(3, 2).Value & "/update"
End If

'HTTPリクエスト発行　→　ApiHttpControl.bas参照
'リクエスト発行時にVBA-JSONでDictionaryをJson形式にコンバート
Set objHTTP = HTTPリクエスト発行(strUrl, CreateRecordJson)
    
'レスポンスjsonをパース（VBA-JSON）
Set Parse = JsonConverter.ParseJson(objHTTP.responseText)

'エクセルに結果を転記
Worksheets(sheetName).Cells(6, 2).Value = objHTTP.statusText & "(Status:" & objHTTP.Status & ")"
Worksheets(sheetName).Cells(7, 2).Value = "=HYPERLINK(""" & Worksheets(sheetName).Cells(4, 2).Value & _
    "/items/" & Parse("Id") & "/"",""" & Parse("Id") & """)"

まとめ

使い慣れたExcelシートから汎用的にPleasanterにアクセスできるようになりました。
次回、このツールを活用し、より実践的な使い方を考えてみます。