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

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

前提
- 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