238 lines
6.8 KiB
QBasic
238 lines
6.8 KiB
QBasic
Attribute VB_Name = "Module4"
|
||
Option Explicit
|
||
'##########################################################################################################
|
||
' callRestApi
|
||
' restAPIリクエスト汎用関数
|
||
' getAttachmentsFile
|
||
' 添付ファイル
|
||
' exportFileList
|
||
' 取得したファイル情報をシートに保存
|
||
|
||
|
||
'******************************************************************************
|
||
'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
|
||
|
||
'******************************************************************************
|
||
'guidから添付ファイルのバイナリデータを取得する
|
||
Function getAttachmentsFile(guid As String, saveFolderPath As String) As Boolean
|
||
'共通変数
|
||
Dim apiUrl As String
|
||
Dim apiUrlParam As String
|
||
Dim tableId As String
|
||
|
||
'リクエストURL
|
||
apiUrl = baseURL & "/pleasanter/api/binaries/" & guid & "/"
|
||
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
|
||
|
||
'HTTPリクエスト送信メソッド呼び出し
|
||
Dim res As Object
|
||
Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody)
|
||
|
||
If res("StatusCode") = 200 Then
|
||
'ダウンロードしたBase64データをファイル保存
|
||
Dim base64Data As String
|
||
base64Data = res("Response")("Base64")
|
||
|
||
'**********************************
|
||
'保存するファイルパスを入力
|
||
Dim saveFilePath As String
|
||
saveFilePath = saveFolderPath & "\" & res("Response")("FileName")
|
||
|
||
'**********************************
|
||
'Base64データをデコードして保存
|
||
Dim ret As Long
|
||
ret = DecodeBase64(base64Data, saveFilePath)
|
||
|
||
'完了メッセージを表示
|
||
Debug.Print "ファイルの保存に成功しました：" & saveFilePath & ":" & ret
|
||
If ret = -1 Then
|
||
getAttachmentsFile = True
|
||
End If
|
||
End If
|
||
End Function
|
||
|
||
|
||
'******************************************************************************
|
||
' Base64デコードしてファイル名をつけて保存する（上書き）
|
||
'------------------------------------------------------------------------------
|
||
' 第１引数：Base64の文字列 第2引数：保存ファイル名
|
||
'******************************************************************************
|
||
Function DecodeBase64(ByVal Base64Str As String, ByVal filePath As String) As Long
|
||
'ファイルをBase64デコード
|
||
Dim elm As Object
|
||
Dim ret As Long
|
||
Const adTypeBinary = 1
|
||
Const adSaveCreateOverWrite = 2
|
||
|
||
ret = -1 '初期化
|
||
On Error Resume Next
|
||
Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64")
|
||
elm.DataType = "bin.base64"
|
||
elm.text = Base64Str
|
||
With CreateObject("ADODB.Stream")
|
||
.Type = adTypeBinary
|
||
.Open
|
||
.Write elm.nodeTypedValue
|
||
.SaveToFile filePath, adSaveCreateOverWrite
|
||
.Close
|
||
End With
|
||
If Err.Number <> 0 Then ret = 0
|
||
On Error GoTo 0
|
||
DecodeBase64 = ret
|
||
End Function
|
||
|
||
Sub jsonToSheetTest()
|
||
Dim jsonStr As String
|
||
Dim targetSheet As String
|
||
Dim targetCol As String
|
||
|
||
'保管するシート名
|
||
targetSheet = "JSONデータ"
|
||
|
||
'読み込むデータと吐き出す位置
|
||
jsonStr = Range("契約会社json").value
|
||
targetCol = 2
|
||
Call jsonToSheet(jsonStr, targetSheet, targetCol)
|
||
|
||
jsonStr = Range("施工会社json").value
|
||
targetCol = 4
|
||
Call jsonToSheet(jsonStr, targetSheet, targetCol)
|
||
|
||
jsonStr = Range("契約営業所json").value
|
||
targetCol = 6
|
||
Call jsonToSheet(jsonStr, targetSheet, targetCol)
|
||
|
||
jsonStr = Range("契約ブランドjson").value
|
||
targetCol = 8
|
||
Call jsonToSheet(jsonStr, targetSheet, targetCol)
|
||
|
||
jsonStr = Range("シリーズjson").value
|
||
targetCol = 10
|
||
Call jsonToSheet(jsonStr, targetSheet, targetCol)
|
||
|
||
jsonStr = Range("支払情報JSON").value
|
||
targetCol = 14
|
||
Call jsonToSheet2(jsonStr, targetSheet, targetCol)
|
||
|
||
|
||
End Sub
|
||
|
||
'******************************************************************************
|
||
'json文字列を分解し、指定したシート・セルの位置に展開する
|
||
Function jsonToSheet(ByVal jsonStr As String, ByVal targetSheet As String, ByVal targetCol As Long)
|
||
Debug.Print ">>> Json文字列を分析し、シートに書き出す"
|
||
|
||
Dim jsonObj As Object
|
||
Dim key1, key2
|
||
Dim item1, item2
|
||
Dim i
|
||
|
||
i = 3
|
||
|
||
'データクリア
|
||
With Worksheets(targetSheet)
|
||
.Range(.Cells(i, targetCol), .Cells(1000, targetCol + 1)).ClearContents
|
||
End With
|
||
|
||
'JSON文字列が空文字の場合終了
|
||
If jsonStr = "" Then
|
||
Exit Function
|
||
End If
|
||
|
||
'デシリアライズ
|
||
Set jsonObj = JsonConverter.ParseJson(jsonStr)
|
||
For Each key1 In jsonObj
|
||
|
||
If IsObject(jsonObj(key1)) Then
|
||
'中身がオブジェクトの場合はもう一度分解
|
||
For Each key2 In jsonObj(key1)
|
||
item2 = jsonObj(key1)(key2)
|
||
Worksheets(targetSheet).Cells(i, targetCol) = key2
|
||
Worksheets(targetSheet).Cells(i, targetCol + 1) = item2
|
||
i = i + 1
|
||
Next key2
|
||
Else
|
||
item1 = jsonObj(key1)
|
||
Worksheets(targetSheet).Cells(i, targetCol) = key1
|
||
Worksheets(targetSheet).Cells(i, targetCol + 1) = item1
|
||
i = i + 1
|
||
End If
|
||
|
||
Next key1
|
||
|
||
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'json文字列を分解し、指定したシート・セルの位置に展開する その2
|
||
'配列タイプ
|
||
Function jsonToSheet2(ByVal jsonStr As String, ByVal targetSheet As String, ByVal targetCol As Long)
|
||
Debug.Print ">>> Json文字列を分析し、シートに書き出す その2"
|
||
|
||
Dim jsonObj As Object
|
||
Set jsonObj = JsonConverter.ParseJson(jsonStr)
|
||
|
||
Dim key1, item1
|
||
Dim obj
|
||
Dim i, j
|
||
|
||
i = 3
|
||
|
||
For Each obj In jsonObj
|
||
j = targetCol
|
||
|
||
For Each key1 In obj
|
||
item1 = obj(key1)
|
||
Worksheets(targetSheet).Cells(i, j) = item1
|
||
j = j + 1
|
||
Next key1
|
||
|
||
i = i + 1
|
||
|
||
Next obj
|
||
|
||
|
||
End Function
|
||
|
||
|
||
|