251 lines
8.4 KiB
QBasic
251 lines
8.4 KiB
QBasic
Attribute VB_Name = "Module3"
|
||
Option Explicit
|
||
'##########################################################################################################
|
||
' getMSSlist
|
||
' MSS案件一覧の取得
|
||
' getMSSlistRequest
|
||
' プリザンターマスターシートから指定営業所の全データを取得する
|
||
' exportToMSSlist
|
||
' プリザンターマスターシートから取得したリストデータを書き込む
|
||
|
||
'******************************************************************************
|
||
'MSSからデータをリストで取得する
|
||
Sub getMSSlist()
|
||
Application.ScreenUpdating = False '画面更新停止
|
||
Application.Calculation = xlManual '自動計算停止
|
||
|
||
Call init
|
||
'Debug.Print ">>> MSSからデータをリストで取得する処理を開始します"
|
||
|
||
'MSSデータ一覧から営業所を取得
|
||
Dim shopName As String
|
||
Dim shopCode As String
|
||
Dim statusName As String
|
||
Dim statusCode As String
|
||
|
||
shopName = Range("営業所指定").value
|
||
statusName = Range("ステータス").value
|
||
|
||
'営業所とステータスはどちらか必ず指定
|
||
If shopName = "" And statusName = "" Then
|
||
Range("営業所指定").Select
|
||
MsgBox "営業所かステータスを指定してください"
|
||
Else
|
||
'契約コードの個別指定欄を空欄にしてからリスト取得実行
|
||
'Range("契約コード").Value = ""
|
||
|
||
Call getMSSlistRequest
|
||
End If
|
||
|
||
Application.Calculation = xlAutomatic '自動計算開始
|
||
Application.ScreenUpdating = True '画面更新開始
|
||
'Debug.Print "<<< MSSからデータをリストで取得する処理を終了しました"
|
||
End Sub
|
||
|
||
|
||
'******************************************************************************
|
||
'プリザンターマスターシートから指定営業所の全データを取得する
|
||
Function getMSSlistRequest()
|
||
'共通変数
|
||
Dim apiUrl As String
|
||
Dim apiUrlParam As String
|
||
Dim tableId As String
|
||
|
||
'MSSテーブルID
|
||
tableId = "189112"
|
||
|
||
'リクエストURL
|
||
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 currentDate As Date
|
||
currentDate = Date
|
||
|
||
'直近月数を取得し、日付を計算
|
||
Dim delayMonth As Integer
|
||
If Range("直近").value = "" Then
|
||
Range("直近").value = 1
|
||
delayMonth = -1
|
||
Else
|
||
delayMonth = (-1) * Range("直近").value
|
||
End If
|
||
|
||
Dim previousYearDate As Date
|
||
previousYearDate = DateAdd("m", delayMonth, currentDate)
|
||
|
||
'文字列に変換
|
||
Dim previousYearDateString As String
|
||
previousYearDateString = Format(previousYearDate, "yyyy/mm/dd")
|
||
previousYearDateString = previousYearDateString & " 00:00:00"
|
||
|
||
'Debug.Print previousYearDateString
|
||
|
||
'Filter変数
|
||
Dim colFilter As New Dictionary
|
||
Dim shopID As String
|
||
Dim statusID As String
|
||
Dim salesID As String
|
||
Dim yakuinID As String
|
||
Dim sekkeiID As String
|
||
Dim bunruiID As String
|
||
|
||
shopID = Range("営業所ID")
|
||
statusID = Range("ステータスID")
|
||
salesID = Range("営業ID")
|
||
sekkeiID = Range("設計ID")
|
||
yakuinID = Range("役員ID")
|
||
bunruiID = Range("シート分類ID")
|
||
|
||
If shopID <> "" Then
|
||
colFilter.Add "ClassF", "[" & shopID & "]"
|
||
End If
|
||
If statusID <> "" Then
|
||
colFilter.Add "Status", "[" & statusID & "]"
|
||
End If
|
||
If salesID <> "" Then
|
||
colFilter.Add "ClassG", "[" & salesID & "]"
|
||
End If
|
||
If sekkeiID <> "" Then
|
||
colFilter.Add "ClassL", "[" & sekkeiID & "]"
|
||
End If
|
||
If yakuinID <> "" Then
|
||
colFilter.Add "Class122", "[" & yakuinID & "]"
|
||
End If
|
||
If bunruiID <> "" Then
|
||
colFilter.Add "ClassP", "[" & bunruiID & "]"
|
||
End If
|
||
|
||
colFilter.Add "UpdatedTime", "[""" & previousYearDateString & ",""]"
|
||
|
||
Dim colSorter As New Dictionary
|
||
colSorter.Add "Status", "asc"
|
||
colSorter.Add "ClassG", "asc"
|
||
|
||
'View変数
|
||
Dim view As New Dictionary
|
||
view.Add "ColumnFilterHash", colFilter
|
||
view.Add "ColumnSorterHash", colSorter
|
||
apiBody.Add "View", view
|
||
|
||
'HTTPリクエスト送信メソッド呼び出し
|
||
Dim res As Object
|
||
Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody)
|
||
|
||
If res("StatusCode") = 200 Then
|
||
'正常に取得できたらシートへ書き込み
|
||
'Call exportToSheetData(res)
|
||
'Debug.Print JsonConverter.ConvertToJson(res("Response")("TotalCount"))
|
||
'Debug.Print "MSSデータリスト 取得成功"
|
||
Call exportToMSSlist(res)
|
||
End If
|
||
|
||
End Function
|
||
|
||
|
||
'******************************************************************************
|
||
'プリザンターマスターシートから取得したリストデータを書き込む
|
||
Function exportToMSSlist(res As Object)
|
||
'リストのクリア
|
||
Worksheets(shMSSlist2).Range("B3:AZ100").ClearContents
|
||
'ステータス Status
|
||
'タイトル ItemTitle
|
||
'シート分類 ClassP*
|
||
'契約営業所 ClassF*
|
||
'主担当営業 ClassG*
|
||
'管理設計 ClassL
|
||
'所属長 ClassY
|
||
'担当役員 Class122
|
||
'契約コード ClassA
|
||
'設計契約 ClassN*
|
||
'契約ブランド Class033*
|
||
'工事名 ClassQ
|
||
'本契約日 DateD
|
||
'設計契約日 DateE
|
||
'着工予定日 DateH
|
||
'上棟予定日 DateJ
|
||
'引渡予定日 DateL
|
||
'最終更新日 UpdatedTime
|
||
|
||
Dim dataCount As Long
|
||
dataCount = res("Response")("TotalCount")
|
||
|
||
If dataCount = 0 Then
|
||
Exit Function
|
||
End If
|
||
|
||
''Debug.Print JsonConverter.ConvertToJson(res("Response")("Data"))
|
||
|
||
Dim i As Long
|
||
For i = 1 To dataCount
|
||
Dim j As Long: j = 2
|
||
|
||
Dim dataArray() As Variant
|
||
ReDim dataArray(1)
|
||
dataArray(1) = res("Response")("Data")(i)("ResultId")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("Status")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ItemTitle")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassP")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassF")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassG")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassL")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassY")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("Class122")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassA")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassN")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("Class033")
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassQ")
|
||
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("DateHash")("DateD"))
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("DateHash")("DateE"))
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("DateHash")("DateH"))
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("DateHash")("DateJ"))
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("DateHash")("DateL"))
|
||
ReDim Preserve dataArray(UBound(dataArray) + 1)
|
||
dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("UpdatedTime"))
|
||
|
||
|
||
Dim k As Long
|
||
For k = 0 To UBound(dataArray)
|
||
Worksheets(shMSSlist2).Cells(i + 2, k + 1) = dataArray(k)
|
||
Next k
|
||
Next i
|
||
|
||
End Function
|
||
|
||
|
||
Function stringToDate(ByVal dateVal As String) As Variant
|
||
If dateVal = "1899-12-30T00:00:00" Then
|
||
stringToDate = ""
|
||
Else
|
||
stringToDate = CDate(Replace(dateVal, "T", " "))
|
||
End If
|
||
End Function
|
||
|