Redmine を Excel から触る（Rest API）

Redmine にはRest API があって、有効設定にするとHTTP経由でXMLかjsonでCRUD(create,read,update,delete）できるらしい。

参考ページ

読み込み
　Redmineのユーザー情報をEXCEL(VBA)で取得してみた
　http://qiita.com/slangsoft/items/ba577745676af658812f
書き込み
　OutlookVBAでRedmineへRestAPI経由でチケット登録する例
　http://qiita.com/haradaj/items/f5d8e2aab6b3ee5f4108
本家リファレンス
　http://www.redmine.org/projects/redmine/wiki/Rest_api

作ったもの

割と汎用的に読み込みと新規作成ができるようになった。まずはクラス。

' clsRedmine.cls



Option Explicit

Private baseUri As String
Private apiKey As String
Private dom As Object

Private Sub Class_Initialize()

    baseUri = vbNullString
    apiKey = vbNullString
    Set dom = CreateObject("MSXML2.DOMDocument")
    dom.async = False
   
End Sub

Public Function postListSheet(strXmlName As String, ws1 As Worksheet, strItem As String)
'ws1 のデータを1行ずつ strXmlName に POST する。
    Dim var1 As Variant
    Dim i As Long, j As Long
    Dim str1 As String
    var1 = ws1.Cells(1, 1).CurrentRegion
   
    For i = 2 To UBound(var1, 1)
        str1 = "<" & strItem & ">"
        For j = 1 To UBound(var1, 2)
            str1 = str1 & "<" & var1(1, j) & ">" & var1(i, j) & "</" & var1(1, j) & ">"
        Next
        str1 = str1 & "</" & strItem & ">"
        postListSheet = postListSheet And postData(strXmlName, str1)
    Next
End Function


Private Function postData(strXmlName As String, strRequestBody As String) As Boolean
'受け取った文字列 strRequestBody を strXmlName に対してPOSTする。
    Dim xhr As Object
    Dim openXmlFullPath As String
   
    openXmlFullPath = baseUri & "/" & strXmlName & ".xml?format=xml&key=" & apiKey
   
    Set xhr = CreateObject("Microsoft.XMLHTTP")
   
    xhr.Open "POST", openXmlFullPath, False
    xhr.SetRequestHeader "Content-Type", "text/xml"
   
    xhr.send (strRequestBody)
   
    If xhr.Status = 201 Then
        postData = True
    Else
        postData = False
    End If
    Debug.Print xhr.Status & " " & xhr.statustext
End Function

Public Function makeListSheet(ws1 As Worksheet, ParamArray Tags() As Variant)
'ws1シートをクリアしてTagsを見出しにしたdom のリストを作成する
    Dim i As Long
    Dim j As Long
    Dim obj1 As Object
    Dim strTest As String
    ws1.Cells.Clear
   
    '見出しを先に出力
    For j = 1 To UBound(Tags) + 1
        ws1.Cells(1, j).Value = Tags(j - 1)
    Next
   
    i = 2
    For Each obj1 In dom.ChildNodes.Item(1).ChildNodes
        For j = 1 To UBound(Tags) + 1
            strTest = obj1.getelementsbytagname(Tags(j - 1)).Item(0).nodetypedvalue
            If strTest <> "" Then
                ws1.Cells(i, j).Value = strTest
            Else
                ws1.Cells(i, j).Value = obj1.getelementsbytagname(Tags(j - 1)).Item(0).getattribute("name")
            End If
        Next
        i = i + 1
    Next
   
End Function


Public Function getData(strXmlName As String) As Object
'strXmlName のXMLをDOMオブジェクトに格納して返す
'blAllProjects = True のときはすべてのプロジェクトに対して処理を行う
    Dim openXmlFullPath As String
   
    dom.setProperty "ServerHTTPRequest", True
  
    openXmlFullPath = baseUri & "/" & strXmlName & ".xml?format=xml&key=" & apiKey

    If Not (dom.Load(openXmlFullPath)) Then
        Dim strErr As String
        With dom.parseError
            strErr = "XML読込失敗" & vbCrLf & _
            vbCrLf & _
            "ErrorCode    : " & .ErrorCode & vbCrLf & _
            "ErrorReason  : " & .reason & vbCrLf & _
            "Line         : " & .Line & vbCrLf & _
            "LinePosition : " & .linepos & vbCrLf & _
            "FilePosition : " & .filepos & vbCrLf & _
            "SourceText   : " & .srcText & vbCrLf & _
            "DocumentUrl  : " & .url
        End With
        MsgBox strErr, vbExclamation
        End
    End If
    Set getData = dom.ChildNodes.Item(1).ChildNodes
   
End Function

Public Sub setBaseUri(argBaseUri As String)
    baseUri = argBaseUri
End Sub

Public Sub setApiKey(argApiKey As String)
    apiKey = argApiKey
End Sub

これを次のような標準モジュールから利用することができる。
チケットやユーザを新規作成する場合はあらかじめシートに必要な項目名とデータを入力しておく。項目名は上記の本家リファレンスページか、実際にURLに接続して確認することができる。

Option Explicit

Const BASEURL As String = "localhost/redmine"
Const APIKEY As String = "xxxxxxxxxxxxxxx"

Public Sub getAllProjectsAndTickets()

    Dim myRedmine As New clsRedmine
   
    '設定
    myRedmine.setBaseUri (BASEURL)
    myRedmine.setApiKey (APIKEY)
   
    'プロジェクトの取得
    myRedmine.getData "projects"             
    myRedmine.makeListSheet ThisWorkbook.Sheets("Projects"), "id", "name", "description", "created_on"

    'チケットの取得
    myRedmine.getData "issues"
    myRedmine.makeListSheet ThisWorkbook.Sheets("Issues"), "project", "id", "subject", "description", "tracker", "status"
   
    'トラッカー
    myRedmine.getData "trackers"
    myRedmine.makeListSheet ThisWorkbook.Sheets("Trackers"), "id", "name"
   
    'カテゴリ
    myRedmine.getData "projects/1/issue_categories"
    myRedmine.makeListSheet ThisWorkbook.Sheets("Categories"), "project", "id", "name"
   
    'ユーザ
    myRedmine.getData "users"
    myRedmine.makeListSheet ThisWorkbook.Sheets("Users"), "id", "login", "firstname", "lastname", "mail"
   
End Sub

Sub createTickets()

    Dim myRedmine As New clsRedmine
   
    '設定
    myRedmine.setBaseUri (BASEURL)
    myRedmine.setApiKey (APIKEY)
   
    'チケットの登録
    myRedmine.postListSheet "issues", ThisWorkbook.Sheets("NewIssues"), "issue"
   
    'ユーザ登録
    'myRedmine.postListSheet "users", ThisWorkbook.Sheets("NewUsers"), "user"

    'カテゴリ登録
    'myRedmine.postListSheet "projects/1/issue_categories", ThisWorkbook.Sheets("NewCategories"), "issue_category"
   
End Sub

便利だ～～！
しかしこれだとカスタムフィールドには対応できていない・・・