VBAでXMLRPCを汎用的に修正してTrac連携をそれに合わせて修正した

課題山積みなのに、最近は通勤電車の中でしかTracいじる時間が取れなくて、何も進んでないんですが、やっと公開できる部品ができたので公開します。（部品なのでこれだけでは何の役にも立ちませんm(_ _)m）
やり始めたきっかけは、以前の記事のTracの設定をXMLRPCでできるようにとかそういったところだったんですが、VBAもよくわからない昔に作ったものはあまりにもひどいので、ほぼ全書き換えしました。XMLRPCを使ってTrac-VBA連携をする基本のモジュールを、Trac用の所とそうでない所を分割してみました。公開する７ファイルの概要は次のものです。ソースはさらにその下に貼り付けます。

1. XMLRPC
MSXML2.XMLHTTPを使ってXMLRPCでサーバと接続する。
2. Map
マップです。XMLRPCで使用する構造体を扱うために使用する。
3. XMLParam
XMLRPCの引数/戻り値とVBAの型の変換をする。
4. ISO8601Date
時差を考慮しXMLRPCとVBAの間の日付を変換する。
5. Base64EncDec
バイナリデータをBase64でエンコードとデコードする
6. TracXMLRPC
TracのXMLRPCのインタフェースを使いやすく。

一つ一つのソースを上げていきます。ライセンスは後に添付するExcelファイルの中にはつけていますがすべてBSDです。
1. XMLRPC
主な関数のSendは可変個数の引数の関数で、一つ目はXMLRPCのメソッド名二つ目以後はそのメソッドの引数になっていて、戻り値は戻り値をCollectionに入れたものです。
※戻り値のParamは必ず一つになるので、Collectionにはしたくなかったんですが、型が違う戻り値を返すのにはこうするしかなかった。
Option Explicit

'Copyright (c) 2011 Yuji OKAZAKI. All rights reserved.

Dim m_URL As String
Dim m_user As String
Dim m_pw As String
Dim m_paramConv As XMLParam
'参照設定が無くても使えるようにする
'http://support.microsoft.com/kb/290761/ja
'Dim m_xmlSv As MSXML2.ServerXMLHTTP
'Dim m_xmlSv As MSXML2.xmlHttp
Dim m_xmlSv As Variant
Dim m_fUserXmlServer As Boolean

Private Sub Class_Initialize()
Set m_paramConv = New XMLParam
End Sub

Public Sub init(URL As String, user As String, pw As String, Optional fUserXmlServer As Boolean = False)
m_URL = URL
m_user = user
m_pw = pw
m_fUserXmlServer = fUserXmlServer
If m_fUserXmlServer Then
Set m_xmlSv = CreateObject("MSXML2.ServerXMLHTTP")
Else
Set m_xmlSv = CreateObject("MSXML2.XMLHTTP")
End If
End Sub

Function CreateParamStr(val As Variant) As String
CreateParamStr = m_paramConv.CreateParamStr(val)
End Function

'接続してレスポンスを得ます
Function Send(ParamArray val()) As Collection
Dim method As String, params As String
method = val(0)
Dim i As Integer
For i = 1 To UBound(val) '最初の一つは捨てる
params = params & "" & CreateParamStr(val(i)) & ""
Next
Set Send = Send0(method, params)
End Function

Function Send0(method As String, params As String) As Collection
m_xmlSv.Open "POST", m_URL, False, m_user, m_pw
m_xmlSv.setRequestHeader "Method", "POST " & m_URL & " HTTP/1.1"
m_xmlSv.setRequestHeader "Content-Type", "text/xml"
If m_fUserXmlServer Then
m_xmlSv.setOption 2, 13056 'SXH_OPTION_SELECT_CLIENT_SSL_CERT
End If
If method <> "" Then
Dim work As Variant
'sendの引数はVariantでないとダメらしい。
work = "" & _
"" & _
"" & method & "" & _
"" & params & "" & _
""
Call m_xmlSv.Send(work)
End If
DoEvents
Dim errorMessage As String
errorMessage = CheckError()
If errorMessage <> "" Then
Debug.Print "==========Error========="
Debug.Print "----------Param---------"
Debug.Print work
Debug.Print "--------Response--------"
Debug.Print m_xmlSv.responsetext
Debug.Print "------Error Message-----"
Debug.Print errorMessage
err.Raise vbObjectError + 515, , errorMessage
End If
Dim p, v, c
Set p = m_xmlSv.responseXML.getElementsByTagName("param")
Set c = New Collection
For Each v In p
'paramは仕様上一つだけど値を返す時にcollection以外だと難しいのでこうする
'Variantに文字列を返すとそれをsetするところでエラーが出るどう対処すればいいかわからないので
c.add m_paramConv.CreateRetVal(v.ChildNodes(0))
Next
Set Send0 = c
End Function

'Responseがエラーかどうかを判断します。
'エラーだった場合は何らかの文字列を返します。
Private Function CheckError() As String
CheckError = ""
Dim Members
Set Members = m_xmlSv.responseXML.getElementsByTagName("fault")
Dim errorMessage As String
errorMessage = ""
If m_xmlSv.status <= 100 Or m_xmlSv.status > 200 Then
'認証に失敗したとかHTTPにアクセスするときまでの問題の処理
errorMessage = "Error:" & m_xmlSv.statusText & "(" & m_xmlSv.status & ")"
ElseIf Members.Length = 0 Then
'faultが無かった場合はちゃんとXMLでレスポンスがあったか確認します．
If m_xmlSv.responseXML.getElementsByTagName("methodResponse").Length > 0 Then
Exit Function
End If
errorMessage = "Not an XML response."
Else
'faultがあった場合エラーメッセージをまとめます
Set Members = m_xmlSv.responseXML.getElementsByTagName("member")
Dim i
For i = 0 To Members.Length - 1
Dim oNodeList
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
End If
CheckError = errorMessage
End Function

2. Map
マップです。VBAのCollectionからキーが取れれば何の問題もないんですが、それができないので二つのCollectionをまとめて、キーと値を保存するようにしました。

'Copyright (c) 2011 Yuji OKAZAKI. All rights reserved.

Option Explicit

Public Keys As Collection
Public Values As Collection

Public Sub Class_Initialize()
Set Keys = New Collection
Set Values = New Collection
End Sub

Public Sub add(Value As Variant, key As String)
Keys.add key, key
Values.add Value, key
End Sub

Public Sub remove(key As String)
Keys.remove key
Values.remove key
End Sub

Public Sub update(Value As Variant, key As String)
On Error Resume Next
remove key
On Error GoTo 0
add Value, key
End Sub

3. XMLParam
ソース中に書いてあるようにVBAの型とXMLRPCの型の相互の変換を行います。

'Copyright (c) 2011 Yuji OKAZAKI. All rights reserved.

Option Explicit

'XMLRPCのデータとVBAのデータの変換を行うクラスです
'i4,int <-> Long,Integer,Byte
'Base64 <- Byte()
'struct <-> Map
'array(s) <-> Collection,?()
'string <-> String
'double <-> Double,Float
'boolean <-> Boolean
'dateTime.iso8601 <-> Date
'エラー;
' method Error number Desciption
' CreateParamStr vbObjectError + 516 変換できない型
' CreateRetVal vbObjectError + 517 仕様にない型

Dim m_date As ISO8601Date
Dim m_base64 As Base64EncDec
Dim m_encode As Long
Dim m_decode As Long

Private Sub Class_Initialize()
Set m_date = New ISO8601Date
Set m_base64 = New Base64EncDec
m_encode = 15
m_decode = 0
End Sub

Function CreateParamStr(val As Variant) As String
Dim strParam
Dim strType As String
strType = typeName(val)
Select Case strType
Case "Byte()"
Dim buf() As Byte
buf = val
strParam = "" & m_base64.encodeBase64(buf) & ""
Case "String"
If m_encode And 1 = 1 Then
val = Replace(val, "&", "&")
End If
If m_encode And 2 = 2 Then
val = Replace(val, "<", "<")
End If
If m_encode And 4 = 4 Then
val = Replace(val, ">", ">")
End If
If m_encode And 8 = 8 Then
val = Replace(val, """", """)
End If
If m_encode And 16 = 16 Then
val = Replace(val, " ", " ")
End If
strParam = "" & val & ""
Case "Double", "Single"
strParam = "" & val & ""
Case "Byte", "Integer", "Long"
strParam = "" & val & ""
Case "Boolean"
If val = False Then
strParam = "0"
Else
strParam = "1"
End If
Case "Date"
Dim d As Date
d = val
strParam = "" & m_date.DateToISODate(d) & ""
Case "Map"
Dim m As Map
Set m = val
Dim k
For Each k In m.Keys
strParam = strParam & "" & k & "" & CreateParamStr(m.Values(k)) & "" & vbCrLf
Next
'valueが一つも無くてもstructになっていないと引数として使用できない。
strParam = "" & strParam & ""
Case "Collection"
Dim a
For Each a In val
strParam = strParam & CreateParamStr(a) & vbCrLf
Next
If InStr(strParam, "") > 0 Or InStr(strParam, "") > 0 Then
strParam = "" & strParam & ""
Else
strParam = "" & strParam & ""
End If
Case Else
If Right(strType, 2) = "()" Then 'VBAの配列の場合はArrayにする
Dim a1
For Each a1 In val
strParam = strParam & CreateParamStr(a1) & vbCrLf
Next
If InStr(strParam, "") > 0 Or InStr(strParam, "") > 0 Then
strParam = "" & strParam & ""
Else
strParam = "" & strParam & ""
End If
Else
err.Raise vbObjectError + 516, "Paramertr error is occurred in CreateParamStr."
End If
End Select
CreateParamStr = strParam
End Function

Function CreateRetVal(val As Variant) As Variant
Dim n As String, v As String, nn
' If val.BaseName <> "value" Then
' Debug.Print "引数のBaseNameはvalueになるようにしてください"
' End If
Set val = val.ChildNodes(0)
Select Case val.BaseName
Case "array", "arrays"
Dim i As Integer
Set CreateRetVal = New Collection
'dataは読み捨てる
Set val = val.ChildNodes(0)
For i = 0 To val.ChildNodes.Length - 1
CreateRetVal.add CreateRetVal(val.ChildNodes(i))
Next
Case "struct"
Dim colV As Map
Set colV = New Map
For Each nn In val.ChildNodes
Dim childNode
Set childNode = nn.ChildNodes(0)
colV.add CreateRetVal(nn.ChildNodes(1)), childNode.ChildNodes(0).text
Next
Set CreateRetVal = colV
Case "int", "i4"
CreateRetVal = CLng(val.text)
Case "string"
Dim strWork As String
strWork = val.text
If m_decode And 16 = 16 Then
strWork = Replace(strWork, " ", " ")
End If
If m_decode And 8 = 8 Then
strWork = Replace(strWork, """, """")
End If
If m_decode And 4 = 4 Then
strWork = Replace(strWork, ">", ">")
End If
If m_decode And 2 = 2 Then
strWork = Replace(strWork, "<", "<")
End If
If m_decode And 1 = 1 Then
strWork = Replace(strWork, "&", "&")
End If
CreateRetVal = strWork
Case "double"
'CDbl
CreateRetVal = CDbl(val.text)
Case "boolean"
CreateRetVal = CBool(val.text)
Case "dateTime.iso8601"
Dim d As ISO8601Date
Set d = New ISO8601Date
CreateRetVal = d.ISODateToDate(val.text)
Case "base64"
CreateRetVal = m_base64.decodeBase64(val.text)
Case Else
err.Raise vbObjectError + 517, , "Unknown type"
End Select
End Function

4. ISO8601Date
時差を考慮しXMLRPCとVBAの間の日付を変換する。

'Copyright (c) 2011 Yuji OKAZAKI. All rights reserved.

Option Explicit

'XMLRPCの日付をExcelの日付に変換します。
Dim m_timeBias As Double '時差(h)

Private Sub Class_Initialize()
m_timeBias = 1# / 60# * GetTimeZoneBias()
End Sub

'時差(m)を取得します
Private Function GetTimeZoneBias() As Integer
Dim TizSet As Object, Tiz As Object, Locator As Object
Set Locator = CreateObject("WbemScripting.SWbemLocator")
Set TizSet = Locator.ConnectServer.ExecQuery("Select * From Win32_TimeZone")
GetTimeZoneBias = 0
For Each Tiz In TizSet
GetTimeZoneBias = Tiz.bias
Exit Function
Next
End Function

'時間を文字列の時間に変換します
'時差なしのXMLRPCの時刻をDateに変換します。
' date:20090317T16:10:12のようなXMLの時刻の文字列
Function ISODateToDate(text As String) As Date
Dim d As Date
If Len(text) = 17 Then
On Error GoTo FORMAT_ERR
d = DateSerial(Mid$(text, 1, 4), Mid$(text, 5, 2), Mid$(text, 7, 2))
d = DateAdd("h", Int(Mid$(text, 10, 2)), d)
d = DateAdd("n", Int(Mid$(text, 13, 2)), d)
d = DateAdd("s", Int(Mid$(text, 16, 2)), d)
d = DateAdd("h", m_timeBias, d)
ISODateToDate = d
On Error GoTo 0
Exit Function
End If
FORMAT_ERR:
err.Raise vbObjectError + 515, , "Error: Date format is wrong (" & text & ")."
End Function

'時間を文字列の時間に変換します
'時差なしのXMLRPCの時刻をDateに変換します。
' date:20090317T16:10:12のようなXMLの時刻の文字列
Function DateToISODate(d As Date) As String
d = DateAdd("h", -m_timeBias, d)
DateToISODate = Format(d, "yyyymmddThh:nn:ss")
End Function

5. Base64EncDec
バイナリデータをBase64でエンコードとデコードする

'Copyright (c) 2011 Yuji OKAZAKI. All rights reserved.

Option Explicit

Private Function encodeBase64Byte(d As Long) As Long
If d < 26 Then
encodeBase64Byte = Asc("A") + d
ElseIf d < 52 Then
encodeBase64Byte = Asc("a") + (d - 26)
ElseIf d < 62 Then
encodeBase64Byte = Asc("0") + (d - 52)
ElseIf d < 63 Then
encodeBase64Byte = Asc("+")
ElseIf d < 64 Then
encodeBase64Byte = Asc("/")
End If
End Function

Private Function decodeBase64Byte(b As Byte) As Long
If b >= Asc("A") And b <= Asc("Z") Then
decodeBase64Byte = b - Asc("A")
ElseIf b >= Asc("a") And b <= Asc("z") Then
decodeBase64Byte = b - Asc("a") + 26
ElseIf b >= Asc("0") And b <= Asc("9") Then
decodeBase64Byte = b - Asc("0") + 52
ElseIf b = Asc("+") Then
decodeBase64Byte = 62
ElseIf b = Asc("/") Then
decodeBase64Byte = 63
End If
End Function

Public Function encodeBase64(ByRef buf() As Byte) As String
encodeBase64 = ""
Dim fileSize As Long
fileSize = UBound(buf)
Dim d(4) As Long, e(4) As Long
Dim pos As Long, posL As Integer, l As Long
For pos = 0 To fileSize
l = l * (2 ^ 8) + buf(pos)
posL = posL + 1
If posL = 3 Then
posL = 0
d(1) = CLng((l And (63 * (2 ^ 18))) / (2 ^ 18))
d(2) = CLng((l And (63 * (2 ^ 12))) / (2 ^ 12))
d(3) = CLng((l And (63 * (2 ^ 6))) / (2 ^ 6))
d(4) = CLng(l And 63)
e(1) = encodeBase64Byte(d(1))
e(2) = encodeBase64Byte(d(2))
e(3) = encodeBase64Byte(d(3))
e(4) = encodeBase64Byte(d(4))
encodeBase64 = encodeBase64 + Chr(CByte(e(1))) + Chr(CByte(e(2))) + Chr(CByte(e(3))) + Chr(CByte(e(4)))
l = 0
End If
Next
If posL >= 1 Then
If posL = 1 Then
l = l * (2 ^ 16)
Else
l = l * (2 ^ 8)
End If
d(1) = CLng((l And (63 * (2 ^ 18))) / (2 ^ 18))
d(2) = CLng((l And (63 * (2 ^ 12))) / (2 ^ 12))
d(3) = CLng((l And (63 * (2 ^ 6))) / (2 ^ 6))
e(1) = encodeBase64Byte(d(1))
e(2) = encodeBase64Byte(d(2))
e(3) = encodeBase64Byte(d(3))
If posL = 1 Then
encodeBase64 = encodeBase64 + Chr(CByte(e(1))) + Chr(CByte(e(2))) + "=="
Else
encodeBase64 = encodeBase64 + Chr(CByte(e(1))) + Chr(CByte(e(2))) + Chr(CByte(e(3))) + "="
End If
End If
End Function

Public Function decodeBase64(strText As String) As Variant
Dim buf() As Byte
Dim strSize As Long, bufSize As Long
strSize = Len(strText)
bufSize = strSize
ReDim buf(bufSize)
Dim pos As Long, posBuf As Long
Dim posL As Integer
For pos = 1 To strSize
Dim l As Long, l2 As Long, b As Byte, s As String
Do
b = Asc(Mid(strText, pos, 1))
If b = 10 Then
'改行の場合は読み飛ばす
pos = pos + 1
ElseIf b = Asc("=") Then
Exit For
Else
Exit Do
End If
Loop
'デコードした値は6ビット
l = l * (2 ^ 6) + decodeBase64Byte(b)
posL = posL + 1
If posL = 4 Then
'6*4=24bit集まったら,3Byte分出力する
On Error Resume Next
buf(posBuf) = CByte((l / (2 ^ 16)) And 255)
buf(posBuf + 1) = CByte((l / (2 ^ 8)) And 255)
buf(posBuf + 2) = CByte((l And 255))
On Error GoTo 0
l = 0
posBuf = posBuf + 3
posL = 0
End If
Next
If posL = 3 Then
l = l * (2 ^ 6)
buf(posBuf) = CByte((l / (2 ^ 16)) And 255)
buf(posBuf + 1) = CByte((l / (2 ^ 8)) And 255)
posBuf = posBuf + 2
ElseIf posL = 2 Then
l = l * (2 ^ 12)
buf(posBuf) = CByte((l / (2 ^ 16)) And 255)
posBuf = posBuf + 1
End If
ReDim Preserve buf(posBuf - 1)
decodeBase64 = buf
End Function

6. TracXMLRPC
過去のものとの違いは、milestoneやresolution等をproperty setで設定できるようにした。添付ファイルの取得に対応。などなど

'Copyright (c) 2009-2011 Yuji OKAZAKI. All rights reserved.

Option Explicit

Dim m_xmlrpc As XMLRPC
Dim m_URL As String
Dim m_projectName As String

Dim m_priority As Collection
Dim m_resolution As Collection
Dim m_severity As Collection
Dim m_type As Collection
'statusは更新できない
Dim m_status As Collection

Dim m_component As Map
Dim m_version As Map
Dim m_milestone As Map

Dim m_field As Map

'クラスを初期化します．各引数は次のように指定してください
'URL:http://localhost/trac
'projectName:SampleProject
'user:admin
'pw:admin
Public Sub init(URL As String, projectName As String, user As String, pw As String, Optional fUserXmlServer As Boolean = False)
m_projectName = projectName
m_URL = URL
If Mid(m_URL, Len(m_URL) - 1) <> "/" Then
m_URL = m_URL & "/"
End If
Set m_xmlrpc = New XMLRPC
If m_projectName <> "" Then
m_xmlrpc.init m_URL & m_projectName & "/login/xmlrpc", user, pw, fUserXmlServer
Else
m_xmlrpc.init m_URL & "login/xmlrpc", user, pw, fUserXmlServer
End If
Set m_milestone = Nothing
Set m_status = Nothing
Set m_version = Nothing
Set m_component = Nothing
Set m_priority = Nothing
Set m_resolution = Nothing
Set m_severity = Nothing
Set m_type = Nothing
Set m_field = Nothing
End Sub

'IDを指定してチケットの情報を取得します
'戻り値がマップに変更になりました
Public Function getTicket(id As Long) As Map
Dim result As Collection
Set result = m_xmlrpc.Send("ticket.get", id)
'取得した結果はCollectionなので一つ目の要素を取得して、
'次のArrayで返ってくる値の中から、id,createtime,timeを捨てます。
Set getTicket = result.Item(1).Item(4)
'idは捨てたので追加します
getTicket.add id, "id"
End Function

Public Function createTicket(summary As String, description As String, attributes As Map, notify As Boolean) As Long
Dim result As Collection
createTicket = 0
On Error Resume Next
'attributeの中にあっても意味がないものを削除
attributes.remove "id"
attributes.remove "summary"
attributes.remove "description"
attributes.remove "time"
attributes.remove "createtime"
On Error GoTo 0
Set result = m_xmlrpc.Send("ticket.create", summary, description, attributes, notify)
createTicket = result.Item(1)
End Function

Public Function updateTicket(id As Long, comment As String, attributes As Map, Optional notify As Boolean = False) As Map
On Error Resume Next
'attributeの中にあっても意味がないものを削除
attributes.remove "id"
attributes.remove "comment"
attributes.remove "time"
attributes.remove "changetime"
On Error GoTo 0
Dim result As Collection
Set result = m_xmlrpc.Send("ticket.update", id, comment, attributes, notify)
Set updateTicket = result.Item(1).Item(4)
updateTicket.add id, "id"
End Function

Public Function getActions(id As Long) As Collection
Set getActions = m_xmlrpc.Send("ticket.getActions", id).Item(1) '変更されたチケットのIDが返ってくる
End Function

'チケットに対する変更内容が配列で取得できます
'配列の要素も配列になっていて、
'変更時刻、更新者、変更項目、旧値、新値になっている。
Public Function changeLog(id As Long) As Collection
Set changeLog = m_xmlrpc.Send("ticket.changeLog", id).Item(1) '変更されたチケットのIDが返ってくる
End Function

'チケット（Map）のCollectionを返します．
'チケットの情報がstructなので、Mapになりました
Public Function queryTicket(query As String) As Collection
Dim params As String
Set queryTicket = New Collection
If query = "" Then
params = ""
Else
params = "" & query & ""
End If
Dim result As Collection
Set result = m_xmlrpc.Send("ticket.query", query)
Dim n
For Each n In result.Item(1)
Dim ticket As Map, R As Collection
Set R = m_xmlrpc.Send("ticket.get", n)
Set ticket = R.Item(1).Item(4)
ticket.add n, "id"
queryTicket.add ticket, "" & n
Next
End Function

'==============================================================================

'milestone等の情報を取得します.指定できるのは次のものです．
'"resolution","milestone","version","component","priority","severity"
Private Function getAllArray(method As String, methodSub As String) As Map
Dim nms As Collection
Set getAllArray = New Map
Set nms = m_xmlrpc.Send(method)
Dim nm
For Each nm In nms.Item(1)
Dim c As Collection
Set c = m_xmlrpc.Send(methodSub, nm)
If c.Count <> 1 Then 'データが取得できない
err.Raise 0, "", ""
Else
getAllArray.add c.Item(1), "" & nm
End If
Next
End Function

Private Function ticketEnumGetAll(enumName As String) As Collection
Set ticketEnumGetAll = Send("ticket." & enumName & ".getAll").Item(1)
End Function

Public Property Get priority() As Collection
If m_priority Is Nothing Then
Set m_priority = ticketEnumGetAll("priority")
End If
Set priority = m_priority
End Property

Public Property Get resolution() As Collection
If m_resolution Is Nothing Then
Set m_resolution = ticketEnumGetAll("resolution")
End If
Set resolution = m_resolution
End Property

Public Property Get severity() As Collection
If m_severity Is Nothing Then
Set m_severity = ticketEnumGetAll("severity")
End If
Set severity = m_severity
End Property

Public Property Get ticketType() As Collection
If m_type Is Nothing Then
Set m_type = ticketEnumGetAll("type")
End If
Set ticketType = m_type
End Property

'表示順はCollectionの中の順になります。
'デフォルト値は設定できないので、どうなるのかわかりません
'名前は変更ではなく削除してからの追加なので、注意してください
Private Function ticketEnumReset(enumNm As String, colOld As Collection, colNew As Collection) As Collection
Dim itemName
Dim nm As String
'今あるものを削除する
For Each itemName In colOld
nm = itemName
Call Send("ticket." & enumNm & ".delete", nm)
Next
'追加する
Dim p As Integer
p = 1
For Each itemName In colNew
nm = itemName
Dim res As Collection
Set res = Send("ticket." & enumNm & ".create", nm, p)
p = p + 1
Next
Set ticketEnumReset = ticketEnumGetAll(enumNm)
End Function

Public Property Set priority(colNew As Collection)
Set m_priority = ticketEnumReset("priority", m_priority, colNew)
End Property

Public Property Set resolution(colNew As Collection)
Set m_resolution = ticketEnumReset("resolution", m_resolution, colNew)
End Property

Public Property Set severity(colNew As Collection)
Set m_severity = ticketEnumReset("severity", m_severity, colNew)
End Property

Public Property Set ticketType(colNew As Collection)
Set m_type = ticketEnumReset("type", m_type, colNew)
End Property

'=======================================================================
'
Private Function ticketModelGetAll(modelName As String) As Map
Set ticketModelGetAll = getAllArray("ticket." & modelName & ".getAll", "ticket." & modelName & ".get")
End Function

'二重のマップになる
'キーはマイルストン名
'due, completed, description, name
'dueのデフォルト値は0なので注意
Public Property Get milestone() As Map
If m_milestone Is Nothing Then
Set m_milestone = ticketModelGetAll("milestone")
End If
Set milestone = m_milestone
End Property

'二重のマップになる
'キーはバージョン名
'time, description, name
'timeのデフォルト値は0なので注意
Public Property Get version() As Map
If m_version Is Nothing Then
Set m_version = ticketModelGetAll("version")
End If
Set version = m_version
End Property

'二重のマップになる
'キーはコンポーネント名
'owner, description, name
'dueのデフォルト値は0なので注意
Public Property Get component() As Map
If m_component Is Nothing Then
Set m_component = ticketModelGetAll("component")
End If
Set component = m_component
End Property

'statusは更新できない
Public Property Get status() As Collection
If m_status Is Nothing Then
Set m_status = ticketEnumGetAll("status")
End If
Set status = m_status
End Property

'表示順はCollectionの中の順になります。
'デフォルト値は設定できないので、どうなるのかわかりません
'名前は変更ではなく削除してからの追加なので、注意してください
Private Function ticketModelReset(enumNm As String, colOld As Map, mapNew As Map) As Map
Dim itemName
Dim nm As String
'今あるものを削除する
On Error Resume Next
For Each itemName In colOld.Keys
nm = itemName
Call Send("ticket." & enumNm & ".delete", nm)
Next
On Error GoTo 0
'追加する
For Each itemName In mapNew.Keys
nm = itemName
Dim res As Collection
Set res = Send("ticket." & enumNm & ".create", nm, mapNew.Values.Item(nm))
Next
Set ticketModelReset = ticketModelGetAll(enumNm)
End Function

Public Property Set milestone(mapNew As Map)
Set m_milestone = ticketModelReset("milestone", m_milestone, mapNew)
End Property

Public Property Set version(mapNew As Map)
Set m_versione = ticketModelReset("version", m_version, mapNew)
End Property

Public Property Set componect(mapNew As Map)
Set m_componect = ticketModelReset("componect", m_componect, mapNew)
End Property

'==========================================================
Public Property Get field() As Map
If m_field Is Nothing Then
Dim res As Collection, f
Set m_field = New Map
Set res = m_xmlrpc.Send("ticket.getTicketFields")
For Each f In res.Item(1)
m_field.add f, f.Values.Item("name")
Next
End If
Set field = m_field
End Property

'============================================================================
Public Function TicketPutAttachment(id As Long, path As String, fileName As String, description As String) As String
Dim n As Long, fileSize As Long
n = FreeFile
fileSize = FileLen(path)
Dim buf() As Byte
ReDim buf(fileSize - 1)
Open path For Binary As #n
Get #n, , buf
Close #n

Dim c As Collection
Set c = m_xmlrpc.Send("ticket.putAttachment", id, fileName, description, buf)
TicketPutAttachment = c.Item(1)
End Function

'" ticket.listAttachments"
Public Function TicketListAttachments(id As Long) As Collection
Dim c As Collection
Set c = m_xmlrpc.Send("ticket.listAttachments", id)
Set TicketListAttachments = c.Item(1)
End Function

Public Function TicketGetAttachment(id As Long, path As String, fileName As String) As Collection
Dim c As Collection
Set c = m_xmlrpc.Send("ticket.getAttachment", id, fileName)

On Error Resume Next
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFile path
Set FSO = Nothing
On Error GoTo 0

Dim n As Long
n = FreeFile
Dim buff() As Byte
Open path For Binary Access Write As #n
buff = c.Item(1)
Put #n, , buff
Close #n
Set TicketGetAttachment = c
End Function

'=======================================================================
'指定時刻以後に変更のあったチケットのidを配列で返します
Public Function getRecentChanges(since As Date) As Collection
'変更されたチケットのIDが返ってくる
Set getRecentChanges = m_xmlrpc.Send("ticket.getRecentChanges", since).Item(1)
End Function

'接続してレスポンスを得ます
Function Send(ParamArray val()) As Collection
Dim method As String, params As String
method = val(0)
Dim i As Integer
For i = 1 To UBound(val) '最初の一つは捨てる
params = params & "" & m_xmlrpc.CreateParamStr(val(i)) & ""
Next
Set Send = m_xmlrpc.Send0(method, params)
End Function

ほかのExcel連携の部分ができたらもう少し直してTrac-Hacksにあげますが、一応現状のものを上げておきます
「trac.xlsm」をダウンロード
何が起こっても責任とれないので、どうなってもいいところで使ってみてください。