エラー処理とかは適当です
前提
- APIを有効にする
- APIキーを発行する
- VBAエディターでツール→環境設定で「Microsoft XML v6.0」を有効にする
参考
公式のAPIドキュメント
https://www.redmine.org/projects/redmine/wiki/Rest_api
共通
Public Const REDMINE_URL As String = "RedmineのURL"
##チケット新規登録
APIは複数登録可能だけど対応してません
登録に成功すればissue_id にチケット番号が入ります
Public Function CreateIssue( _
ByRef issue_id As String, _
ByVal apiKey As String, _
ByVal parent_issue_id As String, _
ByVal project_id As String, _
ByVal subject As String, _
ByVal tracker_id As String, _
ByVal category_id As String, _
ByVal assigned_to_id As String, _
ByVal start_date As String, _
ByVal due_date As String, _
ByVal estimated_hours As String, _
ByVal done_ratio As String) As Boolean
issue_id = ""
CreateIssue = False
Dim sendBody As Variant
sendBody = "<?xml version=""1.0""?><issue>"
sendBody = sendBody & "<project_id>" & project_id & "</project_id>"
If Len(Trim(parent_issue_id)) > 0 Then
sendBody = sendBody & "<parent_issue_id>" & parent_issue_id & "</parent_issue_id>"
End If
If Len(Trim(subject)) > 0 Then
sendBody = sendBody & "<subject>" & subject & "</subject>"
End If
If Len(Trim(tracker_id)) > 0 Then
sendBody = sendBody & "<tracker_id>" & tracker_id & "</tracker_id>"
End If
If Len(Trim(category_id)) > 0 Then
sendBody = sendBody & "<category_id>" & category_id & "</category_id>"
End If
If Len(Trim(assigned_to_id)) > 0 Then
sendBody = sendBody & "<assigned_to_id>" & assigned_to_id & "</assigned_to_id>"
End If
If Len(Trim(start_date)) > 0 Then
sendBody = sendBody & "<start_date>" & start_date & "</start_date>"
End If
If Len(Trim(due_date)) > 0 Then
sendBody = sendBody & "<due_date>" & due_date & "</due_date>"
End If
If Len(Trim(estimated_hours)) > 0 Then
sendBody = sendBody & "<estimated_hours>" & estimated_hours & "</estimated_hours>"
End If
If Len(Trim(done_ratio)) > 0 Then
sendBody = sendBody & "<done_ratio>" & done_ratio & "</done_ratio>"
End If
sendBody = sendBody & "</issue>"
Dim xmlHttp As New MSXML2.XMLHTTP60
With xmlHttp
.Open "POST", REDMINE_URL & "issues.xml?key=" & apiKey, False
.setRequestHeader "Content-Type", "text/xml"
.send sendBody
If .Status = 201 Then
'XMLデータを取り込む
Dim doc As DOMDocument60
Set doc = New DOMDocument60
doc.LoadXML (.responseText)
issue_id = doc.SelectSingleNode("issue/id").Text
CreateIssue = True
Else
MsgBox .responseText
End If
End With
Set xmlHttp = Nothing
End Function
##更新
チケット更新
Public Function UpdateIssue( _
ByVal issueId As Integer, _
ByVal apiKey As String, _
ByVal parent_issue_id As String, _
ByVal subject As String, _
ByVal tracker_id As String, _
ByVal category_id As String, _
ByVal assigned_to_id As String, _
ByVal start_date As String, _
ByVal due_date As String, _
ByVal estimated_hours As String, _
ByVal done_ratio As String) As Boolean
UpdateIssue = False
Dim sendBody As Variant
sendBody = "<?xml version=""1.0""?><issue>"
If Len(Trim(parent_issue_id)) > 0 Then
sendBody = sendBody & "<parent_issue_id>" & parent_issue_id & "</parent_issue_id>"
End If
If Len(Trim(subject)) > 0 Then
sendBody = sendBody & "<subject>" & subject & "</subject>"
End If
If Len(Trim(tracker_id)) > 0 Then
sendBody = sendBody & "<tracker_id>" & tracker_id & "</tracker_id>"
End If
If Len(Trim(category_id)) > 0 Then
sendBody = sendBody & "<category_id>" & category_id & "</category_id>"
End If
If Len(Trim(assigned_to_id)) > 0 Then
sendBody = sendBody & "<assigned_to_id>" & assigned_to_id & "</assigned_to_id>"
End If
If Len(Trim(start_date)) > 0 Then
sendBody = sendBody & "<start_date>" & start_date & "</start_date>"
End If
If Len(Trim(due_date)) > 0 Then
sendBody = sendBody & "<due_date>" & due_date & "</due_date>"
End If
If Len(Trim(estimated_hours)) > 0 Then
sendBody = sendBody & "<estimated_hours>" & estimated_hours & "</estimated_hours>"
End If
If Len(Trim(done_ratio)) > 0 Then
sendBody = sendBody & "<done_ratio>" & done_ratio & "</done_ratio>"
End If
sendBody = sendBody & "</issue>"
Dim xmlHttp As New MSXML2.XMLHTTP60
With xmlHttp
.Open "PUT", REDMINE_URL & "issues/" & CStr(issueId) & ".xml?key=" & apiKey, False
.setRequestHeader "Content-Type", "text/xml"
.send sendBody
UpdateIssue = True
End With
Set xmlHttp = Nothing
End Function
##プロジェクトID取得
プロジェクト名からプロジェクトIDを取得
Public Function GetProjectId( _
ByRef project_id As String, _
ByVal apiKey As String, _
ByVal project_name As String)
project_id = ""
Dim xmlHttp As New MSXML2.XMLHTTP60
With xmlHttp
.Open "GET", REDMINE_URL & "projects.xml?key=" & apiKey, False
.setRequestHeader "Content-Type", "text/xml"
.send
If .Status = 200 Then
'XMLデータを取り込む
Dim doc As DOMDocument60
Set doc = New DOMDocument60
doc.LoadXML (.responseText)
Dim Node As IXMLDOMNode
For Each Node In doc.SelectSingleNode("projects").ChildNodes
If Node.SelectSingleNode("name").Text = project_name Then
project_id = Node.SelectSingleNode("id").Text
Exit For
End If
Next
If project_id = "" Then
MsgBox "プロジェクトが見つかりませんでした"
End If
Else
MsgBox .responseText
End If
GetProjectId = CStr(.Status)
End With
Set xmlHttp = Nothing
End Function
##トラッカー取得
一覧を連想配列として取得
Public Function GetTrackers( _
ByVal apiKey As String) As Object
Set GetTrackers = CreateObject("Scripting.Dictionary")
Dim xmlHttp As New MSXML2.XMLHTTP60
With xmlHttp
.Open "GET", REDMINE_URL & "trackers.xml?key=" & apiKey, False
.setRequestHeader "Content-Type", "text/xml"
.send
If .Status = 200 Then
'XMLデータを取り込む
Dim doc As DOMDocument60
Set doc = New DOMDocument60
doc.LoadXML (.responseText)
Dim Node As IXMLDOMNode
For Each Node In doc.SelectSingleNode("trackers").ChildNodes
GetTrackers.Add Node.SelectSingleNode("name").Text, Node.SelectSingleNode("id").Text
Next
Else
MsgBox .responseText
End If
End With
Set xmlHttp = Nothing
End Function