« Tracのレポートをチェックして表示するHTA | トップページ | Tracのレポートをチェックして表示するHTA(改XMLRPCもできるように) »

2009年3月15日 (日)

VBAでXML-RPCに接続してみる

ActiveXが入っていないとだめだと思いますが、参照設定なしで使えるようになった。IE入っていれば問題なく使えそうなので少し試してみました。結局たいしたやりとりしないんだから、自前で要求文字列を作りレスポンスを解析すればいいんじゃないかということでこうなりました。

Sub test2()
'    Call getId("http://localhost/trac/SampleProject", "status!=closed&reporter!=okazaki")
'    Call getTicket("http://localhost/trac/SampleProject", 1)
    Call getSeverity("http://localhost/trac/SampleProject")
'    Call getId("http://localhost/trac/SampleProject", "status!=closed&hours!=0")
'    Call getId("http://localhost/trac/SampleProject", "status!=closed&hours!=0")
End Sub

'Tracに接続してResponseを得ます
Function createXmlHttp(ByVal URI As String, user As String, pw As String, method As String, params As String) As Object
    URL = URI & "/login/xmlrpc"
    Set createXmlHttp = CreateObject("MSXML2.XMLHTTP")
    If user = "" Then
        '初回のみパスワード入力のDailogが表示される
        createXmlHttp.Open "POST", URL, False
    Else
        createXmlHttp.Open "POST", URL, False, user, pw
    End If
    createXmlHttp.setRequestHeader "Method", "POST " & URL & " HTTP/1.1"
    createXmlHttp.setRequestHeader "Content-Type", "text/xml"
   
    If method <> "" Then
        param = "<?xml version='1.0' encoding='utf-8'?>" & vbNewLine & _
            "<methodCall>" & _
            "   <methodName>" & method & "</methodName>" & _
            "   <params>" & params & "</params>" & _
            "</methodCall>"
        createXmlHttp.send (param)
        '"fault"
    End If

End Function

'Responseがエラーかどうかを判断します。
Function checkError(oXmlHttp As Object) As Boolean
    checkError = False
    Set Members = oXmlHttp.responseXML.getElementsByTagName("fault")
    Dim errorMessage As String
    errorMessage = ""
    If Members.Length >= 1 Then
        Set Members = oXmlHttp.responseXML.getElementsByTagName("member")
        For i = 0 To Members.Length - 1
            Set oNodeList = Members.Item(i).ChildNodes
            If oNodeList.Item(0).Text = "faultCode" Then
                errorMessage = errorMessage & "Code=" & oNodeList.Item(1).Text
            End If
            If oNodeList.Item(0).Text = "faultString" Then
                errorMessage = errorMessage & ":" & oNodeList.Item(1).Text
            End If
        Next
        checkError = True
    End If
    If oXmlHttp.responseXML.getElementsByTagName("methodResponse").Length = 0 Then
        errorMessage = "XMLでの応答がありませんでした"
    End If
    If errorMessage <> "" Then
        MsgBox errorMessage
    End If
End Function

Sub getSeverity(URI As String)
    Dim oXmlHttp As Object
    'ticket.type.getAll "string"Ok /ticket.milestone.getAll "string"Ok,
    Set oXmlHttp = createXmlHttp(URI, "", "", "system.listMethods", "")
    If checkError(oXmlHttp) Then
'       Exit Sub
    End If
    Range("A:B").ClearContents
    Cells(1, 1) = oXmlHttp.responseText
    Set Members = oXmlHttp.responseXML.getElementsByTagName("string")
    r = 2
    For i = 0 To Members.Length - 1
        Set oNodeList = Members.Item(i).ChildNodes
        col = 1
        For Each Item In oNodeList
            Cells(r, col) = Item.Text
            col = col + 1
        Next
        r = r + 1
    Next
    Set oXmlHttp = Nothing
End Sub

Sub getTicket(URI As String, id As Integer)
    Dim oXmlHttp As Object
    Set oXmlHttp = createXmlHttp(URI, "", "", "ticket.get", "<param><value><int>" & id & "</int></value></param>")
    If checkError(oXmlHttp) Then
'       Exit Sub
    End If
    Range("A:B").ClearContents
    Cells(1, 1) = oXmlHttp.responseText
    Set Members = oXmlHttp.responseXML.getElementsByTagName("member")
    r = 2
    For i = 0 To Members.Length - 1
        Set oNodeList = Members.Item(i).ChildNodes
        col = 1
        For Each Item In oNodeList
            Cells(r, col) = Item.Text
            col = col + 1
        Next
        r = r + 1
    Next
    Set oXmlHttp = Nothing
End Sub

Sub getId(URI As String, query As String)
    Dim oXmlHttp As Object
    Set oXmlHttp = createXmlHttp(URI, "", "", "ticket.query", "<param><value><string>" & query & "</string></value></param>")
    If checkError(oXmlHttp) Then
'       Exit Sub
    End If
    Range("A:B").ClearContents
    Cells(1, 1) = oXmlHttp.responseText
    Set Members = oXmlHttp.responseXML.getElementsByTagName("int")
    r = 2
    For i = 0 To Members.Length - 1
'        Set Node = Members.Item(i).FirstChild
        Set oNodeList = Members.Item(i).ChildNodes
        col = 1
        For Each Item In oNodeList
            Cells(r, col) = Item.Text
            col = col + 1
        Next
        r = r + 1
    Next
    Set oXmlHttp = Nothing
End Sub

何か間違っているところを見つけたりしたら教えていただけるとありがたいです。

|

« Tracのレポートをチェックして表示するHTA | トップページ | Tracのレポートをチェックして表示するHTA(改XMLRPCもできるように) »

Trac」カテゴリの記事

VBA」カテゴリの記事

XMLRPC」カテゴリの記事

コメント

コメントを書く



(ウェブ上には掲載しません)


コメントは記事投稿者が公開するまで表示されません。



トラックバック


この記事へのトラックバック一覧です: VBAでXML-RPCに接続してみる:

» TracにXMLRPCで接続するVBAクラスモジュール [いつまでもとりあえず]
いま,MS-ProjectとTracの連携をやっているのですが,Tracに接続す [続きを読む]

受信: 2009年5月27日 (水) 00時18分

« Tracのレポートをチェックして表示するHTA | トップページ | Tracのレポートをチェックして表示するHTA(改XMLRPCもできるように) »