TimeTrackerのWebAPIを活用し、VBAでExcelにTimeTrackerのプロジェクト一覧およびプロジェクトの説明（進捗や状況を記入するメモ欄）を出力するサンプルコードを紹介します。
参考サイト
WebAPIヘルプ：プロジェクト一覧の取得 | TimeTracker NX WebApi ヘルプ
APIキーを生成する： ユーザー設定を変更する | TimeTracker RX ヘルプ
============================================
設定値（ご利用環境に合わせて変更してください）
============================================
Const BASE_URL As String = "https://<YOUR_HOST>/<YOUR_TENANT>/api/project/projects"
Const LOGIN_ID As String = "<LOGIN_ID>"
Const LOGIN_PW As String = "<PASSWORD>"
---------------------------------------------------------------------------------------------------------------------------
Option Explicit
Sub GetProjects()
Dim url As String
url = "https://<YOUR_HOST>/<YOUR_TENANT>/api/project/projects"
Dim http As Object
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
http.setOption 2, 13056
Dim cred As String
cred = B64Enc("<LOGIN_ID>:<PASSWORD>")
http.Open "GET", url, False
http.setRequestHeader "Authorization", "Basic " & cred
http.setRequestHeader "Accept", "application/json"
On Error GoTo ErrHandler
http.Send
On Error GoTo 0
If http.Status <> 200 Then
MsgBox "HTTP " & http.Status & vbCrLf & http.responseText, vbCritical
Exit Sub
End If
Dim json As String
json = http.responseText
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Cells.Clear
ws.Cells(1, 1).Value = "No"
ws.Cells(1, 2).Value = "Code"
ws.Cells(1, 3).Value = "Project Name"
ws.Cells(1, 4).Value = "Manager"
ws.Cells(1, 5).Value = "Organization"
ws.Cells(1, 6).Value = "Start Date"
ws.Cells(1, 7).Value = "Finish Date"
ws.Cells(1, 8).Value = "Description"
ws.Range("A1:H1").Font.Bold = True
Dim pos As Long
Dim row As Long
row = 2
pos = InStr(json, """data"":[")
If pos = 0 Then
MsgBox "data not found", vbCritical
Exit Sub
End If
Dim i As Long
i = 1
Do
Dim namePos As Long
namePos = InStr(pos, json, """name"":""")
If namePos = 0 Then Exit Do
Dim projName As String
projName = ExtractValue(json, namePos)
Dim code As String
Dim codePos As Long
codePos = InStrRev(json, """code"":""", namePos)
If codePos > 0 And namePos - codePos < 200 Then
code = ExtractValue(json, codePos)
Else
code = ""
End If
Dim mgr As String
mgr = FindField(json, namePos, "managerName")
Dim org As String
org = FindField(json, namePos, "organizationName")
Dim sDate As String
sDate = FindField(json, namePos, "plannedStartDate")
If Len(sDate) > 10 Then sDate = Left(sDate, 10)
Dim fDate As String
fDate = FindField(json, namePos, "plannedFinishDate")
If Len(fDate) > 10 Then fDate = Left(fDate, 10)
Dim desc As String
desc = FindField(json, namePos, "description")
ws.Cells(row, 1).Value = i
ws.Cells(row, 2).Value = code
ws.Cells(row, 3).Value = projName
ws.Cells(row, 4).Value = mgr
ws.Cells(row, 5).Value = org
ws.Cells(row, 6).Value = sDate
ws.Cells(row, 7).Value = fDate
ws.Cells(row, 8).Value = desc
row = row + 1
i = i + 1
pos = namePos + Len(projName) + 10
Loop
ws.Columns("A:H").AutoFit
MsgBox (row - 2) & " projects retrieved.", vbInformation
Exit Sub
ErrHandler:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description, vbCritical
End Sub
Function ExtractValue(ByVal json As String, ByVal keyPos As Long) As String
Dim vStart As Long
vStart = InStr(keyPos, json, ":""") + 2
Dim vEnd As Long
vEnd = InStr(vStart, json, """")
If vEnd > vStart Then
ExtractValue = Mid(json, vStart, vEnd - vStart)
Else
ExtractValue = ""
End If
End Function
Function FindField(ByVal json As String, ByVal fromPos As Long, ByVal fieldName As String) As String
Dim fPos As Long
fPos = InStr(fromPos, json, """" & fieldName & """:""")
If fPos > 0 And fPos - fromPos < 1000 Then
FindField = ExtractValue(json, fPos)
Else
Dim fPos2 As Long
fPos2 = InStr(fromPos, json, """" & fieldName & """:")
If fPos2 > 0 And fPos2 - fromPos < 1000 Then
Dim cPos As Long
cPos = fPos2 + Len(fieldName) + 3
Dim cEnd As Long
cEnd = InStr(cPos, json, ",")
Dim cEnd2 As Long
cEnd2 = InStr(cPos, json, "}")
If cEnd2 > 0 And (cEnd = 0 Or cEnd2 < cEnd) Then cEnd = cEnd2
If cEnd > cPos Then
FindField = Mid(json, cPos, cEnd - cPos)
Else
FindField = ""
End If
Else
FindField = ""
End If
End If
End Function
Function B64Enc(ByVal txt As String) As String
Dim b() As Byte
b = StrConv(txt, vbFromUnicode)
Dim xDoc As Object
Set xDoc = CreateObject("MSXML2.DOMDocument")
Dim nd As Object
Set nd = xDoc.createElement("b64")
nd.DataType = "bin.base64"
nd.nodeTypedValue = b
B64Enc = Replace(Replace(nd.text, vbCr, ""), vbLf, "")
Set nd = Nothing
Set xDoc = Nothing
End Function
---------------------------------------------------------------------------------------------------------------------------
私はエンジニアではありませんが、生成AIの力を借りて、プログラムコードを書きました。
いわゆる「バイブコーディング」の実践です。
デンソークリエイトはAIエージェントも販売しています。ご興味ある方はお問い合わせください。
DC Agentiqs - 開発の全工程を、AIが一気通貫で支援｜DC Agentiqs