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"

    '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, "[" & Chr(34) & CStr(defaultSh.Cells(r, "G").Value) & Chr(34) & "]"
        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