Help us understand the problem. What is going on with this article?

エクセルVBAからRedmineにチケットを登録・更新する

エラー処理とかは適当です

前提
- APIを有効にする
- APIキーを発行する
- VBAエディターでツール→環境設定で「Microsoft XML v6.0」を有効にする

image.png

参考
公式の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
kameiy
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
No comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
ユーザーは見つかりませんでした