476 lines
15 KiB
QBasic
476 lines
15 KiB
QBasic
Attribute VB_Name = "Module1"
|
||
Option Explicit
|
||
|
||
Public apiKey As String
|
||
Public baseURL As String
|
||
Public yearFilter As String
|
||
Public tableId As String
|
||
Public defaultSh As Worksheet
|
||
Public fetchMethod As String
|
||
|
||
Function init()
|
||
'Pleasanter API KEY
|
||
apiKey = "6504c8a807677a3a576e10327f3c19876c55736ee45d4a845796b9e7f5e087bfd4bd0d8184863da8cf1733ca635111432ab334aea59102b06a96ee6d2c05190d"
|
||
baseURL = "https://nextoffice.Next-hd.co.jp"
|
||
tableId = Range("着工要因ID")
|
||
|
||
Set defaultSh = ThisWorkbook.Sheets("基本情報")
|
||
fetchMethod = defaultSh.Range("D7").Value
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
Sub run()
|
||
'初期化処理
|
||
Call init
|
||
|
||
defaultSh.Range("D4").Value = Now
|
||
defaultSh.Range("D3").Value = "取込処理中..."
|
||
Application.ScreenUpdating = False '画面更新停止
|
||
Application.Calculation = xlManual '自動計算停止
|
||
'------------------------------------------
|
||
Debug.Print "処理開始"
|
||
|
||
Select Case fetchMethod
|
||
Case "Get"
|
||
Call runGetFlow
|
||
Case Else
|
||
Call runExportFlow
|
||
End Select
|
||
|
||
Debug.Print "処理終了"
|
||
'------------------------------------------
|
||
Application.Calculation = xlAutomatic '自動計算再開
|
||
Application.ScreenUpdating = True '画面更新再開
|
||
defaultSh.Range("D5").Value = Now
|
||
defaultSh.Range("D6").Value = (defaultSh.Range("D5").Value - defaultSh.Range("D4").Value) * 86400
|
||
defaultSh.Range("D3").Value = "取込処理完了"
|
||
End Sub
|
||
|
||
'******************************************************************************
|
||
'Export方式（CSV全件取得）でのデータ取込処理
|
||
Sub runExportFlow()
|
||
Dim resData As Variant
|
||
|
||
Debug.Print "データ取得処理開始（Export方式）"
|
||
resData = exportCSVData(tableId)
|
||
|
||
If IsEmpty(resData) Or resData = "" Then
|
||
Debug.Print "データが取得できませんでした"
|
||
Else
|
||
Call exportCSVDataToSheet(resData, tableId)
|
||
End If
|
||
End Sub
|
||
|
||
'******************************************************************************
|
||
'Get方式（api-record-get-multi）でのデータ取込処理
|
||
Sub runGetFlow()
|
||
Dim records As Collection
|
||
|
||
Debug.Print "データ取得処理開始（Get方式）"
|
||
Set records = getRecordsData(tableId)
|
||
|
||
If records Is Nothing Then
|
||
Debug.Print "データが取得できませんでした"
|
||
ElseIf records.count = 0 Then
|
||
Debug.Print "データが取得できませんでした"
|
||
Else
|
||
Call getRecordsDataToSheet(records, tableId)
|
||
End If
|
||
End Sub
|
||
|
||
'******************************************************************************
|
||
'CSVデータを取得
|
||
Function exportCSVData(tableId As String) As Variant
|
||
'共通変数
|
||
Dim apiUrl As String
|
||
Dim apiUrlParam As String
|
||
|
||
'リクエストURL
|
||
apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/"
|
||
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
|
||
apiBody.Add "ExportId", "1"
|
||
|
||
'Filter・Sorter条件（基本情報シートのFilter表・Sorter表から組み立てる）
|
||
Dim viewObj As Object
|
||
Set viewObj = BuildViewFromSheet()
|
||
If Not viewObj Is Nothing Then
|
||
apiBody.Add "View", viewObj
|
||
End If
|
||
|
||
'HTTPリクエスト送信メソッド呼び出し
|
||
Dim res As Object
|
||
Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody)
|
||
|
||
If res("StatusCode") = 200 Then
|
||
Debug.Print "CSVデータの取得に成功しました"
|
||
exportCSVData = res("Response")("Content")
|
||
|
||
End If
|
||
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'CSVデータをシートに書き込む
|
||
Function exportCSVDataToSheet(csvData As Variant, targetSheet As String)
|
||
Debug.Print "CSVデータをシートに出力開始: " & targetSheet
|
||
'------------------------------------------
|
||
'CSVデータを「テーブル」部分に出力する処理
|
||
Dim ws As Worksheet
|
||
On Error Resume Next
|
||
Set ws = ThisWorkbook.Sheets(targetSheet)
|
||
On Error Goto 0
|
||
|
||
If ws Is Nothing Then
|
||
Debug.Print "シートが存在しないため新規作成: " & targetSheet
|
||
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
|
||
ws.Name = targetSheet
|
||
End If
|
||
|
||
'CSVデータをテーブルに挿入（ダブルクォート内の改行・カンマに対応したCSVパース）
|
||
Dim i As Long, j As Long
|
||
Dim arr() As Variant
|
||
Dim maxCols As Long
|
||
|
||
Dim rows As Collection
|
||
Set rows = ParseCsv(csvData)
|
||
|
||
If rows.count <= 1 Then
|
||
MsgBox "データが存在しません（ヘッダのみ）: " & targetSheet, vbExclamation
|
||
Exit Function
|
||
End If
|
||
|
||
maxCols = 0
|
||
Dim rowArr As Variant
|
||
For Each rowArr In rows
|
||
If UBound(rowArr) + 1 > maxCols Then
|
||
maxCols = UBound(rowArr) + 1
|
||
End If
|
||
Next rowArr
|
||
|
||
' 二次元配列を初期化
|
||
ReDim arr(0 To rows.count - 1, 0 To maxCols - 1)
|
||
|
||
' 配列に格納
|
||
i = 0
|
||
For Each rowArr In rows
|
||
For j = LBound(rowArr) To UBound(rowArr)
|
||
arr(i, j) = rowArr(j)
|
||
Next j
|
||
i = i + 1
|
||
Next rowArr
|
||
|
||
'テーブル（ListObject）取得
|
||
Dim tbl As ListObject
|
||
On Error Resume Next
|
||
Set tbl = ws.ListObjects(targetSheet)
|
||
On Error Goto 0
|
||
|
||
If tbl Is Nothing Then
|
||
Debug.Print "テーブルが存在しないため新規作成: " & targetSheet
|
||
Dim headerRange As Range
|
||
Set headerRange = ws.Range("A1").Resize(1, maxCols)
|
||
For j = 0 To maxCols - 1
|
||
headerRange.Cells(1, j + 1).Value = arr(0, j)
|
||
Next j
|
||
Set tbl = ws.ListObjects.Add(xlSrcRange, headerRange, , xlYes)
|
||
tbl.Name = targetSheet
|
||
End If
|
||
|
||
'テーブルのデータ部分をクリア
|
||
If Not tbl.DataBodyRange Is Nothing Then
|
||
tbl.DataBodyRange.ClearContents
|
||
End If
|
||
|
||
' テーブルにデータを追加（ヘッダ行(arr(0,*))を除いたデータ部分のみをDataBodyRangeに書き込む）
|
||
tbl.Resize tbl.Range.Resize(rows.count, maxCols)
|
||
|
||
Dim dataArr() As Variant
|
||
ReDim dataArr(1 To rows.count - 1, 1 To maxCols)
|
||
For i = 1 To rows.count - 1
|
||
For j = 1 To maxCols
|
||
dataArr(i, j) = arr(i, j - 1)
|
||
Next j
|
||
Next i
|
||
tbl.DataBodyRange.Value = dataArr
|
||
|
||
'------------------------------------------
|
||
Debug.Print "CSVデータをシートに出力完了: " & targetSheet
|
||
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'CSV文字列をパースし、行ごとのフィールド配列を格納したCollectionを返す
|
||
'ダブルクォートで囲まれたフィールド内の改行・カンマ・エスケープされた""に対応（RFC4180準拠）
|
||
Private Function ParseCsv(Byval csvText As String) As Collection
|
||
Dim rows As New Collection
|
||
Dim fields As Collection
|
||
Set fields = New Collection
|
||
|
||
Dim field As String
|
||
Dim inQuotes As Boolean
|
||
Dim i As Long, ch As String, nextCh As String
|
||
Dim textLen As Long
|
||
textLen = Len(csvText)
|
||
inQuotes = False
|
||
field = ""
|
||
|
||
i = 1
|
||
Do While i <= textLen
|
||
ch = Mid(csvText, i, 1)
|
||
|
||
If inQuotes Then
|
||
If ch = """" Then
|
||
nextCh = Mid(csvText, i + 1, 1)
|
||
If nextCh = """" Then
|
||
field = field & """"
|
||
i = i + 1
|
||
Else
|
||
inQuotes = False
|
||
End If
|
||
Else
|
||
field = field & ch
|
||
End If
|
||
Else
|
||
Select Case ch
|
||
Case """"
|
||
inQuotes = True
|
||
Case ","
|
||
fields.Add field
|
||
field = ""
|
||
Case vbCr, vbLf
|
||
If ch = vbCr And Mid(csvText, i + 1, 1) = vbLf Then i = i + 1
|
||
fields.Add field
|
||
field = ""
|
||
If Not (fields.count = 1 And fields(1) = "") Then
|
||
rows.Add CollectionToArray(fields)
|
||
End If
|
||
Set fields = New Collection
|
||
Case Else
|
||
field = field & ch
|
||
End Select
|
||
End If
|
||
i = i + 1
|
||
Loop
|
||
|
||
'最終フィールド・行（末尾に改行が無い場合）
|
||
If field <> "" Or fields.count > 0 Then
|
||
fields.Add field
|
||
rows.Add CollectionToArray(fields)
|
||
End If
|
||
|
||
Set ParseCsv = rows
|
||
End Function
|
||
|
||
'Collection（1次元）を0始まりのVariant配列に変換
|
||
Private Function CollectionToArray(Byval col As Collection) As Variant
|
||
Dim arr() As Variant
|
||
ReDim arr(0 To col.count - 1)
|
||
Dim k As Long
|
||
For k = 1 To col.count
|
||
arr(k - 1) = col(k)
|
||
Next k
|
||
CollectionToArray = arr
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'基本情報シートのFilter表(F2:G2見出し、F3以降データ)・Sorter表(H2:I2見出し、H3以降データ)を読み取り、
|
||
'APIリクエストのViewパラメータに渡すDictionaryを組み立てる。
|
||
'Filter・Sorterともに0件の場合はNothingを返す（Viewパラメータ自体を付与しないため）
|
||
Function BuildViewFromSheet() As Object
|
||
Dim colFilter As New Dictionary
|
||
Dim r As Long
|
||
r = 3
|
||
Do While Trim(defaultSh.Cells(r, "F").Value) <> ""
|
||
colFilter.Add defaultSh.Cells(r, "F").Value, defaultSh.Cells(r, "G").Value
|
||
r = r + 1
|
||
Loop
|
||
|
||
Dim colSorter As New Dictionary
|
||
r = 3
|
||
Do While Trim(defaultSh.Cells(r, "H").Value) <> ""
|
||
colSorter.Add defaultSh.Cells(r, "H").Value, defaultSh.Cells(r, "I").Value
|
||
r = r + 1
|
||
Loop
|
||
|
||
If colFilter.count = 0 And colSorter.count = 0 Then
|
||
Set BuildViewFromSheet = Nothing
|
||
Exit Function
|
||
End If
|
||
|
||
Dim viewObj As New Dictionary
|
||
If colFilter.count > 0 Then
|
||
viewObj.Add "ColumnFilterHash", colFilter
|
||
End If
|
||
If colSorter.count > 0 Then
|
||
viewObj.Add "ColumnSorterHash", colSorter
|
||
End If
|
||
|
||
Set BuildViewFromSheet = viewObj
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'Get方式（api-record-get-multi）でレコードを取得する
|
||
'成功時、レコードDictionaryのCollection(Response.Data)を返す
|
||
Function getRecordsData(tableId As String) As Collection
|
||
Dim apiUrl As String
|
||
Dim apiUrlParam As String
|
||
|
||
apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/"
|
||
apiUrlParam = "get"
|
||
|
||
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 viewObj As Object
|
||
Set viewObj = BuildViewFromSheet()
|
||
If Not viewObj Is Nothing Then
|
||
apiBody.Add "View", viewObj
|
||
End If
|
||
|
||
Dim res As Object
|
||
Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody)
|
||
|
||
If res("StatusCode") = 200 Then
|
||
Debug.Print "レコードの取得に成功しました"
|
||
Set getRecordsData = res("Response")("Data")
|
||
End If
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'レコードDictionary内のネストした*Hash（ClassHash、NumHash、DateHash、DescriptionHash、CheckHashなど）を
|
||
'展開し、1階層のDictionaryにフラット化する
|
||
Function FlattenRecord(record As Dictionary) As Dictionary
|
||
Dim flat As New Dictionary
|
||
Dim key As Variant
|
||
For Each key In record.Keys
|
||
If TypeName(record(key)) = "Dictionary" Then
|
||
Dim innerKey As Variant
|
||
For Each innerKey In record(key).Keys
|
||
flat.Add innerKey, record(key)(innerKey)
|
||
Next innerKey
|
||
Else
|
||
flat.Add key, record(key)
|
||
End If
|
||
Next key
|
||
Set FlattenRecord = flat
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'Get方式で取得したレコードをシートに書き込む（exportCSVDataToSheetとは独立実装）
|
||
'ヘッダはフラット化後の1件目レコードのキー一覧をそのまま使用する（内部キー名のまま、日本語ラベル変換はしない）
|
||
Function getRecordsDataToSheet(records As Collection, targetSheet As String)
|
||
Debug.Print "レコードをシートに出力開始: " & targetSheet
|
||
|
||
If records.count = 0 Then
|
||
MsgBox "データが存在しません: " & targetSheet, vbExclamation
|
||
Exit Function
|
||
End If
|
||
|
||
Dim ws As Worksheet
|
||
On Error Resume Next
|
||
Set ws = ThisWorkbook.Sheets(targetSheet)
|
||
On Error GoTo 0
|
||
|
||
If ws Is Nothing Then
|
||
Debug.Print "シートが存在しないため新規作成: " & targetSheet
|
||
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
|
||
ws.Name = targetSheet
|
||
End If
|
||
|
||
Dim flatRecords As New Collection
|
||
Dim rec As Variant
|
||
For Each rec In records
|
||
flatRecords.Add FlattenRecord(rec)
|
||
Next rec
|
||
|
||
Dim headerDict As Dictionary
|
||
Set headerDict = flatRecords(1)
|
||
Dim headerKeys As Variant
|
||
headerKeys = headerDict.Keys
|
||
Dim maxCols As Long
|
||
maxCols = headerDict.count
|
||
|
||
Dim i As Long, j As Long
|
||
Dim dataArr() As Variant
|
||
ReDim dataArr(1 To flatRecords.count, 1 To maxCols)
|
||
For i = 1 To flatRecords.count
|
||
Dim curRec As Dictionary
|
||
Set curRec = flatRecords(i)
|
||
For j = 1 To maxCols
|
||
dataArr(i, j) = curRec(headerKeys(j - 1))
|
||
Next j
|
||
Next i
|
||
|
||
Dim tbl As ListObject
|
||
On Error Resume Next
|
||
Set tbl = ws.ListObjects(targetSheet)
|
||
On Error GoTo 0
|
||
|
||
Dim headerRange As Range
|
||
Set headerRange = ws.Range("A1").Resize(1, maxCols)
|
||
For j = 0 To maxCols - 1
|
||
headerRange.Cells(1, j + 1).Value = headerKeys(j)
|
||
Next j
|
||
|
||
If tbl Is Nothing Then
|
||
Debug.Print "テーブルが存在しないため新規作成: " & targetSheet
|
||
Set tbl = ws.ListObjects.Add(xlSrcRange, headerRange, , xlYes)
|
||
tbl.Name = targetSheet
|
||
End If
|
||
|
||
If Not tbl.DataBodyRange Is Nothing Then
|
||
tbl.DataBodyRange.ClearContents
|
||
End If
|
||
|
||
tbl.Resize tbl.Range.Resize(flatRecords.count + 1, maxCols)
|
||
tbl.DataBodyRange.Value = dataArr
|
||
|
||
Debug.Print "レコードのシート出力完了: " & targetSheet
|
||
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
|