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

    On Error GoTo Cleanup

    defaultSh.Range("D4").Value = Now
    defaultSh.Range("D3").Value = "取込処理中..."
    Application.ScreenUpdating = False '画面更新停止
    Application.Calculation = xlManual '自動計算停止
    '------------------------------------------
    Debug.Print "処理開始"

    Dim success As Boolean
    Select Case fetchMethod
        Case "Get"
            success = runGetFlow()
        Case Else
            success = runExportFlow()
    End Select

    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 success 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

    Debug.Print "データ取得処理開始（Export方式）"
    resData = exportCSVData(tableId)

    If IsEmpty(resData) Or resData = "" Then
        Debug.Print "データが取得できませんでした"
        runExportFlow = False
    Else
        'Get方式実行時のヘッダ列構成が残っている場合に備え、既存テーブルを削除してから作り直す
        On Error Resume Next
        ThisWorkbook.Sheets(tableId).ListObjects(tableId).Delete
        On Error GoTo 0

        Call exportCSVDataToSheet(resData, tableId)
        runExportFlow = True
    End If
End Function

'******************************************************************************
'Get方式（api-record-get-multi）でのデータ取込処理
'成功時True、データを取得できなかった場合Falseを返す
Function runGetFlow() As Boolean
    Dim records As Collection

    Debug.Print "データ取得処理開始（Get方式）"
    Set records = getRecordsData(tableId)

    If records Is Nothing Then
        Debug.Print "データが取得できませんでした"
        runGetFlow = False
    ElseIf records.count = 0 Then
        Debug.Print "データが取得できませんでした"
        runGetFlow = False
    Else
        Call getRecordsDataToSheet(records, tableId)
        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, "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 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
            If IsObject(curRec(headerKeys(j - 1))) Then
                dataArr(i, j) = ""
            Else
                dataArr(i, j) = curRec(headerKeys(j - 1))
            End If
        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


'******************************************************************************
'基本情報シートに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("H2:I2")
        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