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("D3").Value = "取込処理中..."
    Application.ScreenUpdating = False '画面更新停止
    Application.Calculation = xlManual '自動計算停止
    '------------------------------------------
    Debug.Print "処理開始"

    'CSVデータ取得処理
    Dim resData As Variant

    Debug.Print "データ取得処理開始"
    'テーブルのCSVデータ取得
    resData = exportCSVData(tableId)

    'resDataが空の場合はスキップ
    If IsEmpty(resData) Or resData = "" Then
        Debug.Print "データが取得できませんでした"
    Else
        'CSVデータをシートに出力
        Call exportCSVDataToSheet(resData, tableId)
    End If


    Debug.Print "処理終了"
    '------------------------------------------
    Application.Calculation = xlAutomatic '自動計算再開
    Application.ScreenUpdating = True '画面更新再開
    defaultSh.Range("D3").Value = "取込処理完了"
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変数
    'Dim colFilter As New Dictionary
    'colFilter.Add "ClassZ", "[" & yearFilter & "]"

    'View変数
    'Dim view As New Dictionary
    'view.Add "ColumnFilterHash", colFilter
    'apiBody.Add "View", view

    '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

'******************************************************************************
'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