feat: 取得方式(D7)を読み込むfetchMethod変数を追加

2026-09-11 13:12:33 +09:00 · 2026-09-11 13:12:33 +09:00 · 4dc4b0cc1d
commit 4dc4b0cc1d
parent ee1448504c
1 changed files with 291 additions and 0 deletions
--- a/XVBA/新版着工要因閲覧シート/vba-files/Module/Module1.bas
+++ b/XVBA/新版着工要因閲覧シート/vba-files/Module/Module1.bas
@ -0,0 +1,291 @@
 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
 '******************************************************************************
 '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