feat: 取得方式(D7)を読み込むfetchMethod変数を追加
This commit is contained in:
Kenichiro NOGI
parent
ee1448504c
commit
4dc4b0cc1d
291
XVBA/新版着工要因閲覧シート/vba-files/Module/Module1.bas
Normal file
291
XVBA/新版着工要因閲覧シート/vba-files/Module/Module1.bas
Normal file
@ -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
|
||||
Loading…
Reference in New Issue
Block a user