563 lines
18 KiB
QBasic
563 lines
18 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
|
||
|
||
Function init()
|
||
'Pleasanter API KEY
|
||
apiKey = "6504c8a807677a3a576e10327f3c19876c55736ee45d4a845796b9e7f5e087bfd4bd0d8184863da8cf1733ca635111432ab334aea59102b06a96ee6d2c05190d"
|
||
baseURL = "https://nextoffice.Next-hd.co.jp"
|
||
tableId = Range("着工要因ID")
|
||
|
||
Set defaultSh = ThisWorkbook.Sheets("基本情報")
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
Sub run()
|
||
'初期化処理
|
||
Call init
|
||
|
||
On Error GoTo Cleanup
|
||
|
||
defaultSh.Range("D4").Value = Now
|
||
defaultSh.Range("D3").Value = "取込処理中..."
|
||
Application.ScreenUpdating = False '画面更新停止
|
||
Application.Calculation = xlManual '自動計算停止
|
||
'------------------------------------------
|
||
Debug.Print "処理開始"
|
||
|
||
Dim exportSuccess As Boolean
|
||
Dim getSuccess As Boolean
|
||
exportSuccess = runExportFlow()
|
||
getSuccess = runGetFlow()
|
||
|
||
Debug.Print "処理終了"
|
||
'------------------------------------------
|
||
|
||
Cleanup:
|
||
Application.Calculation = xlAutomatic '自動計算再開
|
||
Application.ScreenUpdating = True '画面更新再開
|
||
defaultSh.Range("D5").Value = Now
|
||
defaultSh.Range("D6").Value = (defaultSh.Range("D5").Value - defaultSh.Range("D4").Value) * 86400
|
||
|
||
If Err.Number <> 0 Then
|
||
defaultSh.Range("D3").Value = "取込処理失敗（エラー）: " & Err.Description
|
||
Err.Clear
|
||
ElseIf Not (exportSuccess And getSuccess) Then
|
||
defaultSh.Range("D3").Value = "取込処理失敗（データ取得エラー）"
|
||
Else
|
||
defaultSh.Range("D3").Value = "取込処理完了"
|
||
End If
|
||
End Sub
|
||
|
||
'******************************************************************************
|
||
'Export方式（CSV全件取得）でのデータ取込処理
|
||
'成功時True、データを取得できなかった場合Falseを返す
|
||
Function runExportFlow() As Boolean
|
||
Dim resData As Variant
|
||
Dim t0 As Double, t1 As Double, t2 As Double
|
||
|
||
Debug.Print "データ取得処理開始（Export方式）"
|
||
t0 = Timer
|
||
resData = exportCSVData(tableId)
|
||
t1 = Timer
|
||
Debug.Print " exportCSVData(API通信) 所要時間: " & Format(t1 - t0, "0.000") & "秒"
|
||
|
||
If IsEmpty(resData) Or resData = "" Then
|
||
Debug.Print "データが取得できませんでした"
|
||
runExportFlow = False
|
||
Else
|
||
Call exportCSVDataToSheet(resData, tableId & "E")
|
||
t2 = Timer
|
||
Debug.Print " exportCSVDataToSheet(パース+書込) 所要時間: " & Format(t2 - t1, "0.000") & "秒"
|
||
runExportFlow = True
|
||
End If
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'Get方式（api-record-get-multi）でのデータ取込処理
|
||
'成功時True、データを取得できなかった場合Falseを返す
|
||
Function runGetFlow() As Boolean
|
||
Dim records As Collection
|
||
Dim t0 As Double, t1 As Double, t2 As Double
|
||
|
||
Debug.Print "データ取得処理開始（Get方式）"
|
||
t0 = Timer
|
||
Set records = getRecordsData(tableId)
|
||
t1 = Timer
|
||
Debug.Print " getRecordsData(API通信) 所要時間: " & Format(t1 - t0, "0.000") & "秒"
|
||
|
||
If records Is Nothing Then
|
||
Debug.Print "データが取得できませんでした"
|
||
runGetFlow = False
|
||
ElseIf records.count = 0 Then
|
||
Debug.Print "データが取得できませんでした"
|
||
runGetFlow = False
|
||
Else
|
||
Call getRecordsDataToSheet(records, tableId & "G")
|
||
t2 = Timer
|
||
Debug.Print " getRecordsDataToSheet(書込) 所要時間: " & Format(t2 - t1, "0.000") & "秒"
|
||
runGetFlow = True
|
||
End If
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'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, "J").Value) <> ""
|
||
colSorter.Add defaultSh.Cells(r, "J").Value, defaultSh.Cells(r, "K").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 Dictionary
|
||
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) = NormalizeGetValue(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
|
||
|
||
'******************************************************************************
|
||
'Get方式で取得した値のうち、ISO8601形式の日付時刻文字列を正規化する
|
||
'YYYY-MM-DDThh:mm:ss形式 → "yyyy/mm/dd"、未設定を示す1899-12-30は空欄にする
|
||
'オブジェクト値（JSON配列等）は空欄にする
|
||
Function NormalizeGetValue(ByVal v As Variant) As Variant
|
||
If IsObject(v) Then
|
||
NormalizeGetValue = ""
|
||
Exit Function
|
||
End If
|
||
|
||
Dim s As String
|
||
s = CStr(v)
|
||
If Len(s) >= 10 And Mid(s, 5, 1) = "-" And Mid(s, 8, 1) = "-" And Mid(s, 11, 1) = "T" Then
|
||
If Left(s, 10) = "1899-12-30" Then
|
||
NormalizeGetValue = ""
|
||
Else
|
||
NormalizeGetValue = Mid(s, 1, 4) & "/" & Mid(s, 6, 2) & "/" & Mid(s, 9, 2)
|
||
End If
|
||
Else
|
||
NormalizeGetValue = v
|
||
End If
|
||
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
|
||
|
||
|
||
'******************************************************************************
|
||
'基本情報シートにFilter表(F2:G2)・Sorter表(H2:I2)のテーブルをセットアップする
|
||
'新版着工要因閲覧シートv0.1.xlsm上で手動実行する想定（run()からは呼ばない）
|
||
'既にテーブルが存在する場合は何もしない
|
||
Sub SetupFilterSorterTables()
|
||
Dim ws As Worksheet
|
||
Set ws = ThisWorkbook.Sheets("基本情報")
|
||
|
||
Dim filterTbl As ListObject
|
||
On Error Resume Next
|
||
Set filterTbl = ws.ListObjects("FilterTable")
|
||
On Error GoTo 0
|
||
|
||
If filterTbl Is Nothing Then
|
||
Dim filterHeader As Range
|
||
Set filterHeader = ws.Range("F2:G2")
|
||
filterHeader.Cells(1, 1).Value = "列名"
|
||
filterHeader.Cells(1, 2).Value = "値"
|
||
Set filterTbl = ws.ListObjects.Add(xlSrcRange, filterHeader, , xlYes)
|
||
filterTbl.Name = "FilterTable"
|
||
End If
|
||
|
||
Dim sorterTbl As ListObject
|
||
On Error Resume Next
|
||
Set sorterTbl = ws.ListObjects("SorterTable")
|
||
On Error GoTo 0
|
||
|
||
If sorterTbl Is Nothing Then
|
||
Dim sorterHeader As Range
|
||
Set sorterHeader = ws.Range("J2:K2")
|
||
sorterHeader.Cells(1, 1).Value = "列名"
|
||
sorterHeader.Cells(1, 2).Value = "昇降順"
|
||
Set sorterTbl = ws.ListObjects.Add(xlSrcRange, sorterHeader, , xlYes)
|
||
sorterTbl.Name = "SorterTable"
|
||
End If
|
||
End Sub |