201 lines
5.9 KiB
QBasic
201 lines
5.9 KiB
QBasic
|
||
Attribute VB_Name = "Module1"
|
||
Option Explicit
|
||
'******************************************************************************
|
||
'REST API呼出処理
|
||
' プリザンターの任意のテーブルからデータを取得するはん用ツール
|
||
Public apiKey As String
|
||
Public baseURL As String
|
||
|
||
Sub run()
|
||
Call getDataFromPleasanterTable
|
||
End Sub
|
||
|
||
Function getDataFromPleasanterTable()
|
||
Debug.Print "------ START ------"
|
||
Application.ScreenUpdating = False '画面更新停止
|
||
Application.Calculation = xlManual '自動計算停止
|
||
|
||
'****************************************
|
||
'初期化
|
||
Call init
|
||
'****************************************
|
||
|
||
'取得設定シート
|
||
Dim ws設定 As Worksheet
|
||
Set ws設定 = ThisWorkbook.Sheets("取得設定")
|
||
|
||
'取得したいテーブルIDを指定
|
||
Dim テーブルID As String
|
||
テーブルID = ws設定.Range("テーブルID").Value
|
||
|
||
'出力シート名
|
||
Dim 出力シート名 As String
|
||
出力シート名 = ws設定.Range("出力シート名").Value
|
||
If 出力シート名 = "" Then
|
||
出力シート名 = テーブルID & "_データ"
|
||
End If
|
||
|
||
'共通変数
|
||
Dim apiUrl As String
|
||
Dim apiUrlParam As String
|
||
|
||
'リクエストURL
|
||
apiUrl = baseURL & "/pleasanter/api/items/" & テーブルID & "/"
|
||
apiUrlParam = "export"
|
||
|
||
'ヘッダ
|
||
Dim apiHeaders As New Dictionary
|
||
apiHeaders.Add "Content-Type", "application/json;charset=utf-8"
|
||
|
||
'リクエストデータ
|
||
Dim apiBody As New Dictionary
|
||
apiBody.Add "ApiVersion", "1.1"
|
||
apiBody.Add "ApiKey", apiKey
|
||
|
||
'フィルタ変数
|
||
Dim colFilter As New Dictionary
|
||
Dim i As Long
|
||
For i = 8 To 17
|
||
If ws設定.Cells(i, 5).Value <> "" Then
|
||
colFilter.Add ws設定.Cells(i, 2).Value, ws設定.Cells(i, 5).Value
|
||
End If
|
||
Next i
|
||
For i = 3 To 22
|
||
If ws設定.Cells(i, 10).Value <> "" And ws設定.Cells(i, 11).Value <> "" And ws設定.Cells(i, 13).Value <> "" Then 'J列, K列, M列
|
||
colFilter.Add ws設定.Cells(i, 12).Value, ws設定.Cells(i, 13).Value 'L列, M列
|
||
End If
|
||
Next i
|
||
|
||
'ソート指定
|
||
Dim colSorter As New Dictionary
|
||
For i = 8 To 17
|
||
If ws設定.Cells(i, 6).Value <> "" Then
|
||
colSorter.Add ws設定.Cells(i, 2).Value, ws設定.Cells(i, 7).Value
|
||
End If
|
||
Next i
|
||
For i = 3 To 22
|
||
If ws設定.Cells(i, 15).Value <> "" And ws設定.Cells(i, 16).Value <> "" And ws設定.Cells(i, 18).Value <> "" Then 'O列, P列, R列
|
||
colSorter.Add ws設定.Cells(i, 17).Value, ws設定.Cells(i, 19).Value 'Q列, S列
|
||
End If
|
||
Next i
|
||
|
||
'View変数
|
||
Dim view As New Dictionary
|
||
view.Add "ColumnFilterHash", colFilter
|
||
view.Add "ColumnSorterHash", colSorter
|
||
apiBody.Add "View", view
|
||
|
||
'HTTPリクエスト送信メソッド呼び出し
|
||
Dim res As Object
|
||
Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody)
|
||
|
||
If res("StatusCode") = 200 Then
|
||
Debug.Print "------ データの取得に成功しました"
|
||
|
||
'データ保存
|
||
Dim csvData As Variant
|
||
csvData = res("Response")("Content")
|
||
Call データ保存(csvData, 出力シート名)
|
||
End If
|
||
|
||
Application.Calculation = xlAutomatic '自動計算開始
|
||
Application.ScreenUpdating = True '画面更新開始
|
||
Debug.Print "------ "
|
||
Debug.Print "------ END ------"
|
||
End Function
|
||
|
||
Function init()
|
||
'パブリック変数に値を格納
|
||
'Pleasanter API KEY
|
||
apiKey = "6504c8a807677a3a576e10327f3c19876c55736ee45d4a845796b9e7f5e087bfd4bd0d8184863da8cf1733ca635111432ab334aea59102b06a96ee6d2c05190d"
|
||
baseURL = "https://nextoffice.Next-hd.co.jp"
|
||
|
||
End Function
|
||
|
||
Function データ保存(csvData As Variant, targetSheet As String)
|
||
Debug.Print "------ CSVデータをシートに出力開始"
|
||
|
||
'targetSheetが存在しない場合は新規作成
|
||
If Not シート確認(targetSheet) Then
|
||
ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
|
||
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = targetSheet
|
||
End If
|
||
|
||
'CSVデータを「テーブル」部分に出力する処理
|
||
Dim ws As Worksheet
|
||
Set ws = ThisWorkbook.Sheets(targetSheet & "")
|
||
ws.Cells.ClearContents
|
||
|
||
'csvDataを一時ファイルに保存
|
||
Dim tempFilePath As String
|
||
tempFilePath = Environ("TEMP") & "\pleasanter_temp.csv"
|
||
|
||
Dim fileNum As Integer
|
||
fileNum = FreeFile
|
||
Open tempFilePath For Output As #fileNum
|
||
Print #fileNum, csvData
|
||
Close #fileNum
|
||
|
||
Debug.Print "一時ファイルに保存: " & tempFilePath
|
||
|
||
Dim tempWb As Workbook
|
||
Set tempWb = Workbooks.Open(tempFilePath)
|
||
|
||
Dim tempWs As Worksheet
|
||
Set tempWs = tempWb.Sheets(1)
|
||
|
||
tempWs.UsedRange.Copy ws.Range("A1")
|
||
|
||
tempWb.Close SaveChanges:=False
|
||
Kill tempFilePath
|
||
|
||
|
||
|
||
Debug.Print "------ "
|
||
Debug.Print "------ CSVデータをシートに出力完了"
|
||
End Function
|
||
|
||
|
||
'******************************************************************************
|
||
'REST API呼出処理
|
||
' method GetかPOSTか
|
||
' url REST APIのURL
|
||
' urlParam リクエストパラメータ（オプション）
|
||
' headers ヘッダ（オプション）
|
||
Function callRestApi(Byval method As String, Byval url As String, Optional Byval urlParam As String = "", Optional Byval headers As Dictionary = Null, Optional Byval body As Dictionary = Null) As Object
|
||
|
||
'HTTPリクエストのオブジェクトを定義
|
||
Dim objHTTP As Object
|
||
Set objHTTP = New XMLHTTP60
|
||
|
||
'HTTPリクエストの接続先を設定
|
||
objHTTP.Open method, url & urlParam, False
|
||
|
||
'リクエストヘッダーを設定（複数ある場合はsetRequestHeaderを複数書けば良いのだ～）
|
||
Dim i As Long
|
||
For i = 0 To headers.count - 1
|
||
objHTTP.setRequestHeader headers.keys(i), headers.items(i)
|
||
Next i
|
||
|
||
'リクエスト送信
|
||
objHTTP.send JsonConverter.ConvertToJson(body)
|
||
|
||
Do While objHTTP.readyState < 4
|
||
DoEvents
|
||
Loop
|
||
|
||
'レスポンスの文字列（objHTTP.responseText）をJsonに変換して返却
|
||
Set callRestApi = JsonConverter.ParseJson(objHTTP.responseText)
|
||
|
||
End Function
|
||
|
||
'シートの存在確認
|
||
Function シート確認(SheetName As String, Optional wb As Excel.Workbook) As Boolean
|
||
Dim Sh As Excel.Worksheet
|
||
If wb Is Nothing Then Set wb = ThisWorkbook
|
||
On Error Resume Next
|
||
Set Sh = wb.Sheets(SheetName)
|
||
On Error Goto 0
|
||
シート確認 = Not Sh Is Nothing
|
||
End Function |