Excel VBA에서 Redmine으로 티켓 등록 및 업데이트
전제
- API 사용
- API 키 발급
- VBA 편집기에서 도구 → 환경 설정에서 "Microsoft XML v6.0"을 사용하도록 설정
참고
공식 API 문서
htps //w w. 어 d 미네. 오 rg / p 로지 cts / re d mine / uki / re st_ ap
공통
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
Reference
이 문제에 관하여(Excel VBA에서 Redmine으로 티켓 등록 및 업데이트), 우리는 이곳에서 더 많은 자료를 발견하고 링크를 클릭하여 보았다 https://qiita.com/kameiy/items/1b0b15c68bf29637321b텍스트를 자유롭게 공유하거나 복사할 수 있습니다.하지만 이 문서의 URL은 참조 URL로 남겨 두십시오.
우수한 개발자 콘텐츠 발견에 전념 (Collection and Share based on the CC Protocol.)