Excel から Redmine の情報を取得する方法

Module1.bas

Option Explicit

Const API = "http://192.168.1.101/redmine/issues/"

Sub ボタン1_Click()
    Dim i As Integer
    i = 2
    
    Do While Cells(i, 1) <> ""
        'エラー処理ルーチン無効化
        On Error GoTo 0
        
        Dim id As String
        id = Cells(i, 1)
        
        Dim issue As Object
        
        'APIアクセスキーなしの場合は、こちらを使用
        Set issue = GetXmlData(API + id + ".xml")
        
        'APIアクセスキーありの場合は、こちらを使用
        'Set issue = GetXmlData(API + id + ".xml?key=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")
        
        'エラー処理ルーチン有効化(プロパティがなかったときは、無視して続行)
        On Error Resume Next
        
        Cells(i, 2) = issue.getElementsByTagName("tracker").Item(0).getAttribute("name")
        Cells(i, 3) = issue.getElementsByTagName("status").Item(0).getAttribute("name")
        Cells(i, 4) = issue.getElementsByTagName("priority").Item(0).getAttribute("name")
        Cells(i, 5) = issue.getElementsByTagName("subject").Item(0).text
        Cells(i, 6) = issue.getElementsByTagName("assigned_to").Item(0).getAttribute("name")
        
        i = i + 1
    Loop
End Sub

XmlLoader.bas

Option Explicit

Public Function GetXmlData(url As String) As Object
    'XMLドキュメントを読み込むには、まず最初にDOMDocumentクラスのインスタンスを作成する
    'http://msdn.microsoft.com/ja-jp/library/aa468547.aspx
    Dim dom As Object
    Set dom = CreateObject("MSXML2.DOMDocument")
    
    'ドキュメントのAsyncプロパティをFalseに設定すると、ドキュメントが完全に読み込まれて
    '処理の準備が整うまで、パーサーはコードにコントロールを返しません。
    dom.async = False
    
    'エラー対策
    'http://support.microsoft.com/kb/281142/ja
    dom.setProperty "ServerHTTPRequest", True
 
    'MSXMLパーサーを使用すると、URLを介してXMLドキュメントを読み込むことができます。
    'ドキュメントを読み込むには､Loadメソッドを使用
    If Not (dom.Load(url)) Then
        Dim text As String
        With dom.parseError
            text = "XML ドキュメントの読み込みに失敗しました。" & vbCrLf & _
                "次のエラーが原因です :" & vbCrLf & _
                vbCrLf & _
                "エラー番号 # : " & .ErrorCode & vbCrLf & _
                "エラー原因 # : " & .reason & vbCrLf & _
                "行 # : " & .Line & vbCrLf & _
                "行位置 : " & .linepos & vbCrLf & _
                "ファイル内の位置 : " & .filepos & vbCrLf & _
                "ソーステキスト : " & .srcText & vbCrLf & _
                "ドキュメントURL : " & .url
        End With
        MsgBox text, vbExclamation
        
        'Err.Raise dom.parseError.ErrorCode
        End '強制終了
    End If
    
    Set GetXmlData = dom.ChildNodes.Item(1)
End Function