TracのXMLRPCを使ったExcelのマクロでmilestoneなどの設定を取得/更新する

少し前まで仕事で、Tracのテンプレートを作成することをやっていたんですが、テンプレートはプロジェクトの設定時にしか適用できないので、プロジェクトを改善していった結果をよそのプロジェクトに反映しづらいんです。これをなんとするために、XMLRPCを使って、Tracの設定をExcelに取り込み、その内容を逆に設定するマクロを作りました。とうぜん独自の変更があるプロジェクトへの適用は気を付けながらやるしかないですが…問題点としては、TracのXMLRPCで設定/取得できることしかあつかえないので、milestone等のdefault値は取得できませんし、カスタムフィールドは取得できても設定できません。（プラグイン作らないといけないのかなぁ）

1．設定
Settingシートを開き、アドレス、プロジェクト名、ユーザ名などを設定してください。

2. インポート
TracからMilestoneなどの設定を取り込みます。
Configシートのそのテーブルの所で右ボタンを押すと、一つのテーブルの取り込みと更新ができますが、Settingシートのインポートテーブルを押すと、すべてのテーブルを一括取り込みを行います。
まずはConfigシートを削除しておいてからやっていただくとわかりやすいと思います。

3. アップデート
アップデートボタンを押すと、現在の設定とかの比較とかなしに、いきなりTracの設定を削除した後追加します。明確には更新ではありませんが、これで問題ないようです。

変更結果の確認

更新先のアドレスかプロジェクト名を変更すれば設定のコピーになります

4. ソース
インデントなくなってしまいますが、一応載せておきます。見づらいのでExcelのVBEditorで見てください
ライセンスはBSDです。
a) TracConfig.bas

Attribute VB_Name = "TracConfig" Sub import_all_tables() Dim user As String, pw As String, URL As String, projectName As String Dim settingSheet As Worksheet Dim trac As TracXMLRPC Set trac = New TracXMLRPC initialize settingSheet, user, pw, URL, projectName trac.init URL, projectName, user, pw ImportTracTableM ThisWorkbook.Names("milestone"), trac.milestone ImportTracTableM ThisWorkbook.Names("component"), trac.component ImportTracTableM ThisWorkbook.Names("version"), trac.version ImportTracTableC ThisWorkbook.Names("type"), trac.ticketType ImportTracTableC ThisWorkbook.Names("priority"), trac.priority ImportTracTableC ThisWorkbook.Names("resolution"), trac.resolution ImportTracTableC ThisWorkbook.Names("severity"), trac.severity ImportTracTableM ThisWorkbook.Names("ticketfield"), trac.field End Sub

Sub table_import()
Dim user As String, pw As String, URL As String, projectName As String
Dim settingSheet As Worksheet
Dim trac As TracXMLRPC
Set trac = New TracXMLRPC

initialize settingSheet, user, pw, URL, projectName
trac.init URL, projectName, user, pw

Select Case Sheet5.selectedTable
Case "milestone"
ImportTracTableM ThisWorkbook.Names("milestone"), trac.milestone
Case "component"
ImportTracTableM ThisWorkbook.Names("component"), trac.component
Case "version"
ImportTracTableM ThisWorkbook.Names("version"), trac.version
Case "type"
ImportTracTableC ThisWorkbook.Names("type"), trac.ticketType
Case "priority"
ImportTracTableC ThisWorkbook.Names("priority"), trac.priority
Case "resolution"
ImportTracTableC ThisWorkbook.Names("resolution"), trac.resolution
Case "severity"
ImportTracTableC ThisWorkbook.Names("severity"), trac.severity
Case "ticketfield"
' If MsgBox("date,date_emptyの情報は取得できませんが、情報の再取得を行ってよろしいですか", vbOKCancel, "") = vbOK Then
ImportTracTableM ThisWorkbook.Names("ticketfield"), trac.field
' End If
End Select
End Sub

Sub update_all_tables()
Dim user As String, pw As String, URL As String, projectName As String
Dim settingSheet As Worksheet
Dim trac As TracXMLRPC
Set trac = New TracXMLRPC

initialize settingSheet, user, pw, URL, projectName
trac.init URL, projectName, user, pw

Dim m As Map
Dim c As Collection
Set m = createMap(ThisWorkbook.Names("milestone"))
Set trac.milestone = m
ImportTracTableM ThisWorkbook.Names("milestone"), trac.milestone
Set m = createMap(ThisWorkbook.Names("component"))
Set trac.component = m
ImportTracTableM ThisWorkbook.Names("component"), trac.component
Set m = createMap(ThisWorkbook.Names("version"))
Set trac.version = m
ImportTracTableM ThisWorkbook.Names("version"), trac.version
Set c = createCollection(ThisWorkbook.Names("type"))
Set trac.ticketType = c
ImportTracTableC ThisWorkbook.Names("type"), trac.ticketType
Set c = createCollection(ThisWorkbook.Names("priority"))
Set trac.priority = c
ImportTracTableC ThisWorkbook.Names("priority"), trac.priority
Set c = createCollection(ThisWorkbook.Names("resolution"))
Set trac.resolution = c
ImportTracTableC ThisWorkbook.Names("resolution"), trac.resolution
Set c = createCollection(ThisWorkbook.Names("severity"))
Set trac.severity = c
ImportTracTableC ThisWorkbook.Names("severity"), trac.severity
End Sub

Sub table_update()
Dim user As String, pw As String, URL As String, projectName As String
Dim settingSheet As Worksheet
Dim trac As TracXMLRPC
Set trac = New TracXMLRPC

initialize settingSheet, user, pw, URL, projectName
trac.init URL, projectName, user, pw

Dim m As Map
Dim c As Collection
Select Case Sheet5.selectedTable
Case "milestone"
Set m = createMap(ThisWorkbook.Names("milestone"))
Set trac.milestone = m
ImportTracTableM ThisWorkbook.Names("milestone"), trac.milestone
Case "component"
Set m = createMap(ThisWorkbook.Names("component"))
Set trac.component = m
ImportTracTableM ThisWorkbook.Names("component"), trac.component
Case "version"
Set m = createMap(ThisWorkbook.Names("version"))
Set trac.version = m
ImportTracTableM ThisWorkbook.Names("version"), trac.version
Case "type"
Set c = createCollection(ThisWorkbook.Names("type"))
Set trac.ticketType = c
ImportTracTableC ThisWorkbook.Names("type"), trac.ticketType
Case "priority"
Set c = createCollection(ThisWorkbook.Names("priority"))
Set trac.priority = c
ImportTracTableC ThisWorkbook.Names("priority"), trac.priority
Case "resolution"
Set c = createCollection(ThisWorkbook.Names("resolution"))
Set trac.resolution = c
ImportTracTableC ThisWorkbook.Names("resolution"), trac.resolution
Case "severity"
Set c = createCollection(ThisWorkbook.Names("severity"))
Set trac.severity = c
ImportTracTableC ThisWorkbook.Names("severity"), trac.severity
End Select
End Sub

Private Sub initialize(ByRef settingSheet As Worksheet, ByRef user As String, ByRef pw As String, ByRef URL As String, ByRef projectName As String)
Set settingSheet = Sheet1

URL = settingSheet.Cells(2, 3).Value
If settingSheet.Cells(5, 3).Value = True Then
Dim frm As PwDlg
Set frm = New PwDlg
frm.Show
user = frm.TextBox1.Value
pw = frm.TextBox2.Value
Unload frm
Else
user = settingSheet.Cells(6, 3).Value
pw = settingSheet.Cells(7, 3).Value
End If
projectName = settingSheet.Cells(3, 3).Value
' query = settingSheet.Cells(4, 3).Value
End Sub
Sub Test()
'データを取得する
Dim user As String, pw As String, URL As String, projectName As String
Dim settingSheet As Worksheet
Dim trac As TracXMLRPC
Set trac = New TracXMLRPC

initialize settingSheet, user, pw, URL, projectName
trac.init URL, projectName, user, pw

ImportTracTableM ThisWorkbook.Names("milestone"), trac.milestone
ImportTracTableM ThisWorkbook.Names("component"), trac.component
ImportTracTableM ThisWorkbook.Names("version"), trac.version

ImportTracTableC ThisWorkbook.Names("type"), trac.ticketType
ImportTracTableC ThisWorkbook.Names("priority"), trac.priority
ImportTracTableC ThisWorkbook.Names("resolution"), trac.resolution
ImportTracTableC ThisWorkbook.Names("severity"), trac.severity

ImportTracTableM ThisWorkbook.Names("ticketfield"), trac.field

Dim m As Map
Dim c As Collection
Set c = createCollection(ThisWorkbook.Names("resolution"))
Set trac.resolution = c
Set m = createMap(ThisWorkbook.Names("milestone"))
Set trac.milestone = m
End Sub

'名前で設定されている列をその範囲に関係なく下まで削除する
'名前の範囲は先頭の一行のみにする
Private Sub ClearTable(nm As name)
Dim row As Integer
row = 1
Do '行方向下に動くループ
If nm.RefersToRange.Cells(row, 1) = "" Then Exit Do
'値の入っていないセルが来たらループを抜ける
nm.RefersToRange.Rows(row) = "" '行ごとクリア
row = row + 1
Loop
nm.RefersTo = nm.RefersToRange.Rows(1) '名前を再設定
End Sub

Sub ImportTracTableC(nameType As name, c As Collection)
Dim t
Dim row As Integer
Dim col As Integer, colT As Integer
Dim bottomLeft As Range
row = 1
ClearTable nameType
colT = nameType.RefersToRange.Columns.Count
If colT <> 1 Then 'カラムが一つの場合は取得値は文字列
Debug.Print "error"
Exit Sub
End If
For Each t In c
Set bottomLeft = nameType.RefersToRange.Cells(row, 1)
bottomLeft = t
row = row + 1
Next
If row > 1 Then
nameType.RefersTo = Range(nameType.RefersToRange.Cells(1, 1), bottomLeft) '名前を再設定
End If
End Sub

Sub ImportTracTableM(nameType As name, m As Map)
Dim t
Dim row As Integer
Dim col As Integer, colT As Integer
Dim bottomLeft As Range
row = 1
ClearTable nameType
colT = nameType.RefersToRange.Columns.Count
If colT <= 1 Then 'カラムが一つの場合は取得値は文字列
Debug.Print "error"
Exit Sub
End If
For Each t In m.Keys
Dim m2 As Map
Set m2 = m.Values.Item(t)
For col = 1 To colT '配列なのでループを回る
Dim itemName As String, itemValue As String
itemName = nameType.RefersToRange.Cells(0, col)
Set bottomLeft = nameType.RefersToRange.Cells(row, col)
On Error Resume Next '設定されてない値は取得できないので無視する
itemValue = ""
Select Case TypeName(m2.Values.Item(itemName))
Case "Collection"
Dim i
For Each i In m2.Values.Item(itemName)
If itemValue = "" Then
itemValue = i
Else
itemValue = itemValue + "|" + i
End If
Next
Case Else
itemValue = m2.Values.Item(itemName)
End Select

bottomLeft = itemValue
On Error GoTo 0
Next
row = row + 1
Next
If row > 1 Then
nameType.RefersTo = Range(nameType.RefersToRange.Cells(1, 1), bottomLeft) '名前を再設定
End If
End Sub

Private Function createCollection(nm As name) As Collection
Dim row As Integer
Dim col As Integer, colT As Integer
Set createCollection = New Collection

colT = nm.RefersToRange.Columns.Count ' milestoneとかのためにあとで使う
row = 1
Do
If nm.RefersToRange.Cells(row, 1) = "" Then Exit Do
createCollection.add nm.RefersToRange.Rows(row).text
row = row + 1
Loop
End Function

Private Function createMap(nm As name) As Map
Dim row As Integer
Dim col As Integer, colT As Integer
Set createMap = New Map

colT = nm.RefersToRange.Columns.Count
row = 1
Do
If nm.RefersToRange.Cells(row, 1) = "" Then Exit Do
Dim m2 As Map
Set m2 = New Map
For col = 1 To colT '配列なのでループを回る
Dim bottomLeft As Range
Set bottomLeft = nm.RefersToRange.Cells(row, col)
On Error Resume Next '設定されてない値は取得できないので無視する
Debug.Print nm.RefersToRange.Cells(0, col) & " = " & bottomLeft
If bottomLeft.Value <> "" Then
m2.add bottomLeft.Value, nm.RefersToRange.Cells(0, col).text
Else
m2.add "", nm.RefersToRange.Cells(0, col).text
End If
On Error GoTo 0
Next
createMap.add m2, m2.Values.Item("name")
' m2.remove "name"
row = row + 1
Loop
End Function

b) TracXMLRPC.cls

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", Me.priority, colNew)
End Property

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

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

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

'=======================================================================
'
Private Sub removeDefaultDate(m As Map, itemName As String)
Dim i
For Each i In m.Values
If i.Values.Item(itemName) = 0 Then
i.update "", itemName
End If
Next
End Sub

Private Function ticketModelGetAll(modelName As String) As Map
Set ticketModelGetAll = getAllArray("ticket." & modelName & ".getAll", "ticket." & modelName & ".get")
'MS-Officeで扱うにはこのデフォルト値はないほうがいい
On Error Resume Next
'TODO:確認
removeDefaultDate ticketModelGetAll, "due"
removeDefaultDate ticketModelGetAll, "completed"
removeDefaultDate ticketModelGetAll, "time"
On Error GoTo 0
End Function

'二重のマップになる
'キーはマイルストン名
'due, completed, description, name
'due,completedのデフォルト値は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
Call Send("ticket." & enumNm & ".create", nm, mapNew.Values.Item(itemName))
Next
Set ticketModelReset = ticketModelGetAll(enumNm)
End Function

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

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

Public Property Set component(mapNew As Map)
Set m_component = ticketModelReset("component", Me.component, 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

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

c) XMLParam.cls

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

「tracconfig.xlsm」をダウンロード

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」をダウンロード
何が起こっても責任とれないので、どうなってもいいところで使ってみてください。

Excelの（名前の管理のところの）名前の範囲の編集と，名前の範囲の値から複数選択するフォームとマクロ

　Excelの「名前」って名前は何とかならないですかね．たぶんこのタイトルじゃ伝わらないですが仕方ない．

入力規則を使ってドロップダウンリストでその中のひとつを選択することはできますが，複数選択したい場合はどうするんだろうって思ったことはありませんか．標準ではできそうにないので(あるなら教えてください)作ってみました．ただ，どのイベントを使ってダイアログを出すかとか，標準ではないのでいろいろめんどうなことはありますが，今回は適当に決めてあります．

1. 名前の内容の編集
表示するリストと，追加に使用するTextの入力領域，ボタンは追加,削除,上,下とOk,Cancelがあれば何とかなるでしょう．

必要な機能は
a)名前の内容でリストの初期化
b)追加ボタンでリストに追加する
c)Textが変更されたときにリストに存在していなくて，""でなければ追加ボタンを有効にする
d)上下に移動できるときはそのボタンを有効にする
e)リストの項目が選択されている場合は削除ボタンを有効にする．

これをフォームにするとこんなかんじ

フォームを表示するためのコード

Public Sub EditStatus()
    Dim frm As ListEditForm
    Set frm = New ListEditForm
    frm.EditName ThisWorkbook.Names("status"), "statusの編集"
End Sub

フォームのコードは

'Copyright (c) 2011 Yuji OKAZAKI. All rights reserved.
'
'Redistribution and use in source and binary forms, with or without modification, are permitted provided
'that the following conditions are met:
'
' 1. Redistributions of source code must retain the above copyright notice, this list of conditions and
'   the following disclaimer.
' 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions
'   and the following disclaimer in the documentation and/or other materials provided with the
'   distribution.
'
'THIS SOFTWARE IS PROVIDED BY THE FREEBSD PROJECT ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
'INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
'A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE FREEBSD PROJECT OR CONTRIBUTORS BE LIABLE
'FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
'NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
'OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
'STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
'THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

'終了したときの状態を保存します．
Public RetCode As Integer

'追加ボタンがクリックされたらリストにテキストの内容を追加する
Private Sub BAdd_Click()
    LName.AddItem Trim(TName.Text) '必要のないスペースは消しておく
    BAdd.Enabled = False
    'TODO:追加した後はテキストを削除したほうがいいのかもしれないので検討する
End Sub

'キャンセルボタンが押されたらダイアログを消す．RetCodeは初期化時に設定済み
Private Sub BCancel_Click()
    Unload Me
End Sub

'削除ボタンが押されたら，選択しているアイテムを削除する
Private Sub BDel_Click()
    For i = 0 To LName.ListCount - 1
        If LName.Selected(i) Then
            LName.RemoveItem i
            BDel.Enabled = LName.ListCount > 0
            Exit Sub
        End If
    Next
End Sub

'下にボタンが押されたときはリストの選択しているアイテムを下に動かす
Private Sub BDown_Click()
    If LName.ListIndex >= 0 Then
        Dim strWork As String
        strWork = LName.list(LName.ListIndex + 1, 0)
        LName.list(LName.ListIndex + 1, 0) = LName.list(LName.ListIndex, 0)
        LName.list(LName.ListIndex, 0) = strWork
        '選択していた位置を一つ下にする
        LName.ListIndex = LName.ListIndex + 1
    End If
End Sub

'OKボタンが押されたら，RetCodeにvbOKを代入してダイアログを消す
Private Sub BOK_Click()
    RetCode = vbOK
    Unload Me
End Sub

'上にボタンが押されたときは選択されたアイテムを上に移動する
Private Sub BUp_Click()
    If LName.ListIndex > 0 Then
        Dim strWork As String
        strWork = LName.list(LName.ListIndex - 1, 0)
        LName.list(LName.ListIndex - 1, 0) = LName.list(LName.ListIndex, 0)
        LName.list(LName.ListIndex, 0) = strWork
        'ひとつ上のアイテムを選択する
        LName.ListIndex = LName.ListIndex - 1
    End If
End Sub

'リストがクリックされたとき？（変更されたときか？）ボタンの状態を変更する
Private Sub LName_Click()
    BUp.Enabled = Not LName.Selected(0)
    BDown.Enabled = Not LName.Selected(LName.ListCount - 1)
    BDel.Enabled = LName.ListCount > 0
End Sub

'テキストの内容から追加ボタンが有効/無効の状態を変更します
'TODO:""を許すとか，重複もありとかの初期設定があってもいいのかもしれない
Private Sub TName_Change()
    Dim fHas As Boolean
    If Trim(TName.Text) = "" Then
        'テキストに何も入っていなければついあする必要はないので追加ボタンは無効にする
        BAdd.Enabled = False
        Exit Sub
    End If
    'リストのアイテムを検索して，テキストと同じものが含まれていた場合は追加できないので追加ボタンを無効にする
    For i = 0 To LName.ListCount - 1
        If Trim(TName.Text) = LName.list(i, 0) Then
            'リストの中に同じ文字列が存在していればボタンを無効にする
            BAdd.Enabled = False
            Exit Sub
        End If
    Next
    BAdd.Enabled = True
End Sub

'フォームの初期状態を設定します
Private Sub UserForm_Initialize()
    '各ボタンの状態を設定する
    BAdd.Enabled = False
    BUp.Enabled = False
    BDown.Enabled = False
    BDel.Enabled = False
    RetCode = vbCancel
End Sub

'=================================================================================================
'外部から呼び出す関数．これに指定した名前を表示し，OKボタンでクローズされた場合は，編集した結果を反映する．
Function EditName(n As Name, captionText As String) As Long
    Dim r As Range
    Set r = n.RefersToRange
    Dim c
    'リストに初期値を設定する
    For Each c In r.Cells
        If Trim(c.Value) <> "" Then 'Trimして""なら追加しない
            LName.AddItem Trim(c.Value)
        End If
    Next
    caption = captionText
   
    Show
    If RetCode = vbOK Then
        '終了のコードがOkの場合
        r.Value = "" 'ここでもと情報を削除
        Dim strWork As String
        Dim i
        For i = 0 To LName.ListCount - 1
            '現在のリストの内容をもともとの位置に入れていく
            r.Worksheet.Cells(r.Row + i, r.Column) = Trim(LName.list(i, 0))
        Next
        Dim strName As String
        Dim NewRange As Range
        Dim BottomRow As Integer
        If LName.ListCount = 0 Then 'ひとつも情報がない場合はあきでもいいので設定する．
            BottomRow = r.Row
        Else
            BottomRow = r.Row + LName.ListCount - 1
        End If
        Set NewRange = r.Worksheet.Range(r.Worksheet.Cells(r.Row, r.Column), r.Worksheet.Cells(BottomRow, r.Column))
        strName = n.Name
        n.Delete
        ActiveWorkbook.Names.Add strName, NewRange
    End If
    ShowForm = RetCode
End Function

使い方は
a) まず名前を設定します．
適当に範囲を選択して，数式->名前の管理->新規作成
b) この名前を編集するためのマクロを作ります
EditStatusをコピーしてststusと書いてあるところをひとつ前で作った名前に変更します．
c) このマクロを動かすためのボタンを作ります
開発->挿入->ボタンでどこかにボタンを追加します．
ボタン上で右クリックして，さっき追加したマクロを選択します．
※リボンのユーザ設定で開発を追加しておいてください．

d)ボタンを押してフォームの動作を確認します

あとは実際に選択する場所です．

2,名前から選択する

ボタンを押されたときの処理は

Sub SelectItems(strName As String, r As Range, title As String)
    Dim frm As ListSelectForm
    Set frm = New ListSelectForm
    Dim n As Name
    Set n = ThisWorkbook.Names(strName)
    If frm.SelectItems(r, n, title, False) = vbOK Then
        Debug.Print "何かやることがあるなら"
    End If
End Sub

'特定のセルでダブルクリックされたときに次の動作を行う
'(2,4):statusを選択する
'(2,5):operationを選択する
'コンテキストメニューだと消すときとかいろいろ面倒なことになるのでダブルクリックが一番よさげ
'キーボード操作に対応するならSelchangeなのかも，でもうっとうしいんじゃないか
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Cells.Row = 2 And Target.Cells.Column = 4 Then
        SelectItems "status", Target.Cells, "statusの選択"
        Cancel = True
    ElseIf Target.Cells.Row = 2 And Target.Cells.Column = 5 Then
        SelectItems "operation", Target.Cells, "operationの選択"
        Cancel = True
    End If
End Sub

フォームの処理は

'Copyright (c) 2011 Yuji OKAZAKI. All rights reserved.
'
'Redistribution and use in source and binary forms, with or without modification, are permitted provided
'that the following conditions are met:
'
' 1. Redistributions of source code must retain the above copyright notice, this list of conditions and
'   the following disclaimer.
' 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions
'   and the following disclaimer in the documentation and/or other materials provided with the
'   distribution.
'
'THIS SOFTWARE IS PROVIDED BY THE FREEBSD PROJECT ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
'INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
'A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE FREEBSD PROJECT OR CONTRIBUTORS BE LIABLE
'FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
'NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
'OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
'STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
'THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Public RetCode As Integer

Private Sub BCancel_Click()
    Unload Me
End Sub

Private Sub BOK_Click()
    RetCode = vbOK
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    RetCode = vbCancel
End Sub

'名前で指定された内容をリストに表示し，指定した場所の内容で選択したリスト
'のあるダイアログを表示して選択させその結果を指定位置に埋め込む
Function SelectItems(rRet As Range, n As Name, title As String, SetValidate As Boolean) As Long
    Dim strSelected As String
    strSelected = rRet.Value
    Dim r As Range
    Set r = n.RefersToRange
    Dim frm As ListSelectForm
    Set frm = New ListSelectForm
   
    Dim col
    Dim sel As Collection
    Set sel = New Collection
    col = Split(strSelected, ",")
    Dim selectedItemText
    For Each selectedItemText In col
        selectedItemText = Trim(selectedItemText)
        sel.Add selectedItemText, selectedItemText
    Next
   
    'リストに内容を入れていく
    Dim c
    For Each c In r.Cells
        Dim work
        work = ","
        On Error Resume Next
        work = sel.Item(c.Value)
        On Error GoTo 0
        frm.LName.AddItem (c.Value)
        If work <> "," Then
            '指定された選択項目に追加した文字列が存在した場合はリストの項目を選択する
            frm.LName.Selected(frm.LName.ListCount - 1) = True
        End If
    Next
    frm.caption = title
    frm.Show
    If frm.RetCode = vbOK Then
        strSelected = ""
        Dim strWork As String
        For i = 0 To frm.LName.ListCount - 1
            If frm.LName.Selected(i) Then
                If strSelected <> "" Then
                    strSelected = strSelected + ","
                End If
                strSelected = strSelected + Trim(frm.LName.list(i, 0))
            End If
        Next
    End If
    SelectItems = frm.RetCode
    If frm.RetCode = vbOK Then
        If SetValidate = True Then
            If InStr(1, strSelected, ",") > 0 Then
                rRet.Validation.Delete
            Else
                rRet.Validation.Add Type:=xlValidateList, Formula1:="=" & n.Name
            End If
        End If
    End If
    rRet.Value = strSelected
End Function

こんな感じですのでxlsmファイルを添付しておきます

「Table.zip」をダウンロード

今日はさすがによっているみたいなので，間違っていたら指摘してください．

状態遷移図からTracのワークフローを作るマクロにTracの設定の取り込み機能追加

ひとつ前の記事のマクロを拡張し、Tracからの取り込みを作りました。確認の手順は次のように。

0. 準備
このファイルはマクロが動作しないとなんの意味もないので、どこかで調べて、Excelでマクロを実行できるように準備しておいてください。マクロが実行できる状態でファイルを開けば、セルのコンテキストメニューにいろいろ追加されているはずですが、追加されていないようなら、VBEditorを開きThisWorkbookの"Workbook_Open"を手動で実行してください。

1. Tracの設定を貼り付け
Trac.iniのワークフローの設定を"アクション"シートのK30にそのまま貼り付けます。

2. 取り込み
どこかのセルを選択して、セルのコンテキストメニューの"ワークフロー設定の取り込み"を実行すると、"設定"シートのstatus,operation,permissionと"アクション"シートの表示名,次のステータス,権限,オペレーション,defaultに値が取り込まれ、ワークフローシートに図とコネクタの一覧が設定されていることが確認できます。
アクションシート

設定シート

ワークフローシート

3. 仮に設定を出力
"コンテキストメニューの"設定を出力する"で"アクション"シートのA30に設定が出力されています。

4. 図をできるだけきれいに作りたいので、ステータスの順番の変更
図のステータスは左方向から右回りの順に書かれていきますので、設定シートのステータスの順番を変更しておきます。ついでにstatusにfixedも追加しておきます。

チケットの種類がか言っていますが気にしないでください。

5. もう一度取り込み
もう一度取り込みを行うと多少ましな図になっていてほしいんですが、Excelの曲線コネクタの限界のようです。当然statusにfixedは存在しますが、何の接続もされていません。

6. ワークフローを編集
権限にTICKET_CLOSEを追加し、コンテキストメニューの"statusとoperationの名前設定"を実行します。次のように、アクションにfixを追加し、resolveを修正します。

fixの表示名は実装済みに変更してください
   

8. 図を編集します
実際どうするかはいろいろ考えないといけないと思いますが、closedに入ってきているコネクタをすべてfixedに接続して、fixedからclosedに入る線（曲線矢印コネクタ）を追加します。（図は下の9のところのを参照）

9. コネクタの一覧を出力して、対応するアクションを確認します。
コンテキストメニューの"コネクタの一覧を更新する"を実行します。
すべてのコネクタにアクションが入っていることを確認してください。同じステータスに遷移するアクションが複数ある場合はアクションをリストから選択してください。

7. 設定を出力
コンテキストメニューの"設定を出力"を選択して設定を出力します。

出来上がった設定は次のようになります。
accept = new,assigned,accepted,reopened -> accepted
accept.name = 着手する
accept.operations = set_owner_to_self
accept.permissions = TICKET_MODIFY
leave = * -> *
leave.default = 1
leave.name = 変更しない
leave.operations = leave_status
reassign = new,assigned,accepted,reopened -> assigned
reassign.name = 担当者変更
reassign.operations = set_owner
reassign.permissions = TICKET_MODIFY
reopen = closed -> reopened
reopen.name = 差し戻す
reopen.operations = del_resolution
reopen.permissions = TICKET_CREATE
resolve = fixed -> closed
resolve.name = 解決にする
resolve.permissions = TICKET_CLOSE
fix = new,assigned,accepted,reopened -> fixed
fix.name = 実装済み
fix.operations = set_resolution
fix.permissions = TICKET_MODIFY

だいぶでかくなったので、マクロのソースはファイルの中身を見てください

「TracWorkFlow20110228.zip」をダウンロード

tracのワークフローをExcelの図で作った状態遷移図から作ってみる

Tracのワークフローを作るのは難しいということをよく聞く。本当に難しいのかってことを少し考えてみる。WorkflowEditorPluginもあるので、私は、ちょっとしたことに気を付けてやれば、難しいというよりめんどうなだけだと思っています。

私は次の二点に気を付けて、

1. 一つのステータスに移動するアクションを（leaveを除いて）一つにする
2. ちょっとした遠回りで済む、必要のない遷移は削除して簡単にしておく。(例：accept->acceptはaccept->assign->accept)

次の手順でワークフローを作っていきます。
1. Visioで状態遷移図を作る（ステータスを配置し曲線のコネクタでつなぐ）
2. アクションを決める
2. 図を印刷してコネクタに番号をつける
3. コネクタ番号をつぶしながら、アクションのリストに遷移元を書いていく

出来上がった図はこんなかんじ。(下の図での担当変更のassignからassignが抜けてます)

ここで終わっても仕方がないので…　「図からワークローが作れればいいな」っていろいろなところで聞くんですが、実際作ってみたらどうなんだろうってことで確かめてみました。まぁ確かに図から自動で作れれば、抜けがあったりしないか確認しなくてよくなるかもしれませんね。

使い方の手順は

1. ステータスとオペレーションの一覧を更新する
設定シートを開き、status,operation,permissionを編集する（一つの表になっていますが、各列の関連はありません）

今回はfixedを追加し終わったら、コンテキストメニューの"statusとoperationの名前設定"を実行

 

2. ステータスのオートシェイプを追加
もともと次の図のようなものが用意されていたとする

コンテキストメニューの"ステータスの一覧を図に反映"を実行して、余計なものがあれば削除され、ないものはシートの左上あたりに追加されます。
※ステータスの追加は必ずこの操作で追加削除してください。

3. ステータスを線でつないでいく
（上の図に間違った接続がありますがそのままにしておきますm(_O_)m）
あとは、追加したFixedにcloseに入ってくるものをすべて接続しなおし、fixedからclosedに移動する曲線コネクタを追加し、検証が面倒になるので必要ないと思っているものを削除してしまいます。

4. アクションの一覧を作る
もとはこんなかんじ

fixを追加してoperationと権限とをcloseから移動し、closeは特別な権限のTICKET_CLOSEを設定する（fixのところの権限はTICKET_MIDIFYでなくTICKET_MODIFYです）

（fixのところの権限はTICKET_MIDIFYでなくTICKET_MODIFYです）

5. コネクタの一覧を更新する
”ワークフロー図”シートを選択して、コンテキストメニューの”コネクタの一覧を更新する”を実行すると次のように一覧が作成されます。

6. 線の一覧にアクションを割り当てる
遷移先のstatusに行くためのactionが一つの場合は、自動で設定されていますが、複数ある場合はアクションを手動でリストから選択し設定します。

7. マクロ ワークフロー設定を出力
コンテキストメニューの”設定を出力する”を実行すると”アクション”シートのA30セルに出力されます。leaveとかは手で追加すると

leave = * -> *
leave.default = 1
leave.name = 変更しない
leave.operations = leave_status
accept = assigned -> accepted
accept.name = 着手する
accept.operations = set_owner_to_self
accept.permissions = TICKET_MODIFY
reassign = new,assigned,accepted,reopened -> assigned
reassign.name = 担当者変更
reassign.operations = set_owner
reassign.permissions = TICKET_MODIFY
reopen = closed -> reopened
reopen.name = 差し戻す
reopen.operations = del_resolution
reopen.permissions = TICKET_CREATE
resolve = new,fixed -> closed
resolve.name = 解決にする
resolve.permissions = TICKET_CLOSE
fix = accepted,assigned -> fixed
fix.name = 実装済
fix.operations = set_resolution
fix.permissions = TICKET_MODIFY

試してみて、楽にはなるような気がしますが、WorkflowEditorPluginで十分なんじゃないかってところが正直な感想です。これを一般的にするには、入力のUI作ったりして重複チェックとかもちゃんとやる必要があると思いますがやる必要はないのかなぁと今はおもっています。

ThisWorkBookのマクロ

n Error GoTo 0
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    コンテキストメニューから削除
End Sub

Private Sub Workbook_Open()
    コンテキストメニューから削除
    Dim Newb
    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = "未接続の直線の検索"
        .OnAction = "未接続の直線の検索"
        .BeginGroup = True
    End With
    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = "ステータスの変更を図に反映"
        .OnAction = "statusの追加と削除"
        .BeginGroup = False
    End With
    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = "コネクタの一覧を更新する"
        .OnAction = "直線の一覧をつくる"
        .BeginGroup = False
    End With
    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = "設定を出力する"
        .OnAction = "設定を出力する"
        .BeginGroup = False
    End With
    Set Newb = Application.CommandBars("Cell").Controls.Add()
    With Newb
        .Caption = "statusとoperationの名前設定"
        .OnAction = "statusとoperationの名前設定"
        .BeginGroup = False
    End With
'
End Sub

Module1のマクロ

'Copyright (c) 2011 Yuji OKAZAKI. All rights reserved.
'
'Redistribution and use in source and binary forms, with or without modification, are permitted provided
'that the following conditions are met:
'
' 1. Redistributions of source code must retain the above copyright notice, this list of conditions and
'   the following disclaimer.
' 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions
'   and the following disclaimer in the documentation and/or other materials provided with the
'   distribution.
'
'THIS SOFTWARE IS PROVIDED BY THE FREEBSD PROJECT ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
'INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
'A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE FREEBSD PROJECT OR CONTRIBUTORS BE LIABLE
'FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
'NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
'OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
'STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
'THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Sub statusの追加と削除()
    Dim s As Worksheet
    Dim sFig As Worksheet
    Dim c As Collection
    Dim oval As Shape
    Set s = Sheet2
    Set sFig = Sheet1
    s.Activate
    If s.Cells(1, 1).Value <> "status" Then
        If s.Cells(1, 1).Value <> "ステータス" Then
            MsgBox "AIセルがstatusではありません"
            Exit Sub
        End If
    End If
    Dim row As Integer
    row = 2
    Set c = New Collection
   
    Do ' status(円)を追加します
        Dim status As String
        status = s.Cells(row, 1)
        If status = "" Then Exit Do
        On Error Resume Next
        Debug.Print status
        Set oval = Nothing
        Set oval = sFig.Shapes.Item(status)
        On Error GoTo 0
        If oval Is Nothing Then ' 存在していなければ追加
            Set oval = sFig.Shapes.AddShape(msoShapeOval, 200, 0, 100, 100)
            oval.TextEffect.Text = status
            oval.name = status
        End If
        c.Add oval, status
        row = row + 1
    Loop
   
    Call statusとoperationの名前設定
   
    For Each sh In sFig.Shapes ' 存在していないstatus(円)を削除
        If sh.AutoShapeType = msoShapeOval Then '楕円
            Dim i As Shape
            Set i = Nothing
            On Error Resume Next
            Set i = c.Item(sh.name)
            On Error GoTo 0
            If i Is Nothing Then '削除する
                MsgBox "statusリストに存在しないステータス(" & sh.name & ")を削除します。"
                sh.Delete
            End If
        End If
    Next
    sFig.Activate
End Sub

Function 未接続の直線を検索0() As Boolean
    Dim s As Worksheet
    Set s = Sheet1
    未接続の直線を検索0 = False
    s.Activate
    For Each sh In s.Shapes
        If sh.AutoShapeType = msoShapeMixed Then '直線 <-だけではないみたい
            Dim i As Shape
            Set i = sh
            If i.Connector Then 'コネクター
                Debug.Print sh.name
                If sh.ConnectorFormat.BeginConnected = False Or sh.ConnectorFormat.EndConnected = False Then
                    Debug.Print "未接続"
                    i.Select
                    MsgBox "未接続のコネクタがあります"
                    Exit Function
                Else
                    Debug.Print "元シェイプ：" & sh.ConnectorFormat.BeginConnectedShape.name
                    Debug.Print "先シェイプ：" & sh.ConnectorFormat.EndConnectedShape.name
                End If
            End If
        End If
    Next
    未接続の直線を検索0 = True
End Function

Sub 未接続の直線の検索()
    If 未接続の直線を検索0() Then
        MsgBox "未接続のコネクタはありませんでした"
    End If
End Sub

Sub 直線の一覧をつくる()
    If Not 未接続の直線を検索0() Then
        Exit Sub
    End If
    Dim s As Worksheet
    Dim row As Integer
    Set s = Sheet1
    row = 2
    For Each sh In s.Shapes
        If sh.AutoShapeType = msoShapeMixed Then '直線?
            If sh.Connector Then '
                If sh.ConnectorFormat.BeginConnected And sh.ConnectorFormat.EndConnected Then
                    Dim status As String, default As String, list As String
                    s.Cells(row, 1).Value = sh.name
                    s.Cells(row, 2).Value = sh.ConnectorFormat.BeginConnectedShape.name
                    status = sh.ConnectorFormat.EndConnectedShape.name
                    s.Cells(row, 3).Value = status
                    'ここでアクションをみて
                    特定のステータスに遷移するアクションの情報を取得する status, default, list
                    コネクタにアクションを設定する s.Cells(row, 4), default, list
                    row = row + 1
                End If
            End If
        End If
    Next
    Do
        If s.Cells(row, 1).Value = "" Then
            Exit Do
        End If
        s.Cells(row, 1).Value = ""
        s.Cells(row, 2).Value = ""
        s.Cells(row, 3).Value = ""
        s.Cells(row, 4).Validation.Delete
        s.Cells(row, 4).Value = ""
        row = row + 1
    Loop
End Sub

Private Sub 特定のステータスに遷移するアクションの情報を取得する(status As String, ByRef default As String, ByRef list As String)
    Dim s As Worksheet
    Set s = Sheet3
    Dim row As Integer
    Dim count As Integer
    row = 2
    count = 0
    default = ""
    list = ""
    Do
        Dim action As String
        action = s.Cells(row, 3)
        If action = "" Then
            Exit Do
        End If
        If action = status Then
            If count = 0 Then
                default = s.Cells(row, 1)
                list = s.Cells(row, 1)
            Else
                list = list + "," + s.Cells(row, 1)
            End If
            count = count + 1
        End If
        row = row + 1
    Loop
    If count > 1 Then
        default = ""
    End If
End Sub

Sub コネクタにアクションを設定する(c As Range, default As String, list As String)
    Dim s As Worksheet
    Set s = Sheet1
    On Error Resume Next
    With c.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=list
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
    End With
    On Error GoTo 0
    c.Value = default
End Sub

Sub statusとoperationの名前設定()
    Dim s As Worksheet
    Dim n As name
    Set s = Sheet2
    If s.Cells(1, 1).Value <> "status" Then
        Exit Sub
    End If
    Dim row As Integer
    row = 2
    Do
        If s.Cells(row, 1).Value = "" Then Exit Do
        row = row + 1
    Loop
    '名前statusの削除
    If row >= 3 Then
        On Error Resume Next
        ActiveWorkbook.Names("status").Delete
        On Error GoTo 0
        ActiveWorkbook.Names.Add "status", s.Range(s.Cells(2, 1), s.Cells(row - 1, 1))
    End If
   
    If s.Cells(1, 2).Value <> "operation" Then
        Exit Sub
    End If
    row = 2
    Do
        If s.Cells(row, 2).Value = "" Then Exit Do
        row = row + 1
    Loop
    '名前statusの削除
    If row >= 3 Then
        On Error Resume Next
        ActiveWorkbook.Names("operation").Delete
        On Error GoTo 0
        ActiveWorkbook.Names.Add "operation", s.Range(s.Cells(2, 2), s.Cells(row - 1, 2))
    End If

    If s.Cells(1, 3).Value <> "権限" Then
        Exit Sub
    End If
    row = 2
    Do
        If s.Cells(row, 3).Value = "" Then Exit Do
        row = row + 1
    Loop
    '名前statusの削除
    If row >= 3 Then
        On Error Resume Next
        ActiveWorkbook.Names("権限").Delete
        On Error GoTo 0
        ActiveWorkbook.Names.Add "権限", s.Range(s.Cells(2, 3), s.Cells(row - 1, 3))
    End If
End Sub

Sub 設定を出力する()
    Dim s As Worksheet
    Set s = Sheet3
    Dim row As Integer
    Dim count As Integer
    row = 2
    s.Cells(30, 1).Value = ""
    If アクション未設定の有無() Then
        MsgBox "アクションが未設定のコネクタがあります"
        Exit Sub
    End If
    Do
        Dim action As String
        Dim name As String
        Dim next_status As String
        Dim permission As String
        Dim operation As String
        action = s.Cells(row, 1)
        If action = "" Then
            Exit Do
        End If
        name = s.Cells(row, 2)
        next_status = s.Cells(row, 3)
        permission = s.Cells(row, 4)
        operation = s.Cells(row, 5)
        s.Cells(30, 1).Value = s.Cells(30, 1).Value + action & " = " & 元ステータス(action) & " -> " & next_status + vbCrLf
        s.Cells(30, 1).Value = s.Cells(30, 1).Value + action & ".name = " & name + vbCrLf
        If operation <> "" Then
            s.Cells(30, 1).Value = s.Cells(30, 1).Value + action & ".operations = " & operation + vbCrLf
        End If
        s.Cells(30, 1).Value = s.Cells(30, 1).Value + action & ".permissions = " & permission + vbCrLf
        row = row + 1
    Loop
    s.Activate
End Sub

Private Function アクション未設定の有無() As Boolean
    Dim s As Worksheet
    Dim row As Integer
    Set s = Sheet1
    row = 2
    アクション未設定の有無 = False
    Do
        If s.Cells(row, 1).Value = "" Then
            Exit Do
        End If
        If s.Cells(row, 4).Value = "" Then
            アクション未設定の有無 = True
        End If
        row = row + 1
    Loop
End Function

Private Function 元ステータス(action As String) As String
    Dim s As Worksheet
    Dim row As Integer
    Set s = Sheet1
    row = 2
    元ステータス = ""
    Do
        If s.Cells(row, 4).Value = "" Then
            Exit Do
        End If
        If s.Cells(row, 4).Value = action Then
            If 元ステータス <> "" Then
                元ステータス = 元ステータス + ","
            End If
            元ステータス = 元ステータス + s.Cells(row, 2).Value
        End If
        row = row + 1
    Loop
End Function

「TracWorkFlow.zip」をダウンロード 

Excel2010でしか確認してません。変なものを作りこんだ気はありませんが、ダウンロードしたファイルを使用したことによって、何が起こっても責任持ちません。なんかVBAいじくるの疲れてきたんでここいらへんでいったん終わらせます。

（アクションシートのfixのところの権限はTICKET_MIDIFYでなくTICKET_MODIFYに修正しないと動作しません。resolveのところのTICKET_CLOSE権限を作らない場合はTICKET_MODIFYに変更してください）

TracのデータからバーンダウンチャートをExcelで作る

私の場合はできるだけ紙に印刷してみたいので，またまたExcelを使用するということになるのですが，TimingAndEstimate(T&E)プラグインを入れたときに入力ができるようになる項目などなどを利用してバーンダウンチャートを作成します．サーバ側は一つ前の記事のものをTracDependencyPluginに追加しておいたので，それを使います．出来上がる図は次のようになり，バーンダウンチャートしてみれば余計なものがいっぱい入っていますが，ガントチャートの時間変化を，バーンダウンチャート内に表しているものと考えれば，完了日予想に結構使えるはず．これについては，また後日説明を書きます．いつものように，メモレベルですのでお許しを…

バーンダウンチャート

Tracに接続する部分の一部を抜き出すと，次のようにマップの配列を取得できるようにしただけですね．

Public Function getWorkHours(id As Integer) As Collection
    Dim funcName As String, params As String
    funcName = "dependency.getWorkHours"
    params = "<param><value><int>" & id & "</int></value></param>"
    Set getWorkHours = getStructArray2(funcName, params)
End Function

Public Function executeQuery(query As String, sort As String) As Collection
    Dim funcName As String, params As String
    funcName = "dependency.executeQuery"
    params = "<param><value><string>" & query & "</string></value></param>" & _
            "<param><value><string>" & sort & "</string></value></param>"
    Set executeQuery = getStructArray2(funcName, params)
End Function

Public Function getStructArray2(funcName As String, params As String) As Collection
    Dim dataType As String
    Dim ret As Collection
    Dim t As Date
    Set Members = getMember(funcName, params, "struct")
    If Members Is Nothing Then
        Exit Function
    End If
    If Members.Length = 0 Then
        Exit Function
    End If
    Set getStructArray2 = New Collection
    For i = 0 To Members.Length - 1
        Dim d As Collection
        Set oNodeList = Members.Item(i).ChildNodes
        Set d = New Collection
        For j = 0 To oNodeList.Length - 1
            Set oValList = oNodeList(j).ChildNodes
            n = oValList(0).text '値
            v = oValList(1).text '値
            nn = oValList(1).ChildNodes(0).nodeName 'ノード名
            If nn = "dateTime.iso8601" Then
                Dim s As String
                s = v
                v = convertDate(s) '日付を修正
            End If
            d.Add v, n 'コレクションに値を追加
'            Debug.Print "    " & n & "=" & v
        Next
        If oNodeList.Length <> 0 Then
            getStructArray2.Add d
        End If
    Next
End Function

情報をシートに配置していくところは次のようになります．少し変なのは，日付に二日以上の空きがあった場合は，24h前に一つのデータを追加して，休日をはさんでもグラフの線の傾きがゆるくならないようにしています．ほかのやり方もいろいろあるんですが，一日の区切りをどこにするかとか，決める必要が出てくるのでこうしてあります．

Function createBurndown(trac As TracXMLRPC, bd As Worksheet, id As Integer, row As Integer) As Integer
    Dim ticket As Collection
    Set ticket = trac.getTicket("" & id)
    '先頭の数行の情報を設定します．グラフを作るためには使用していません．
    bd.Cells(row, 1).value = ticket.Item("ID")
    bd.Cells(row + 1, 1).value = "計画"
    bd.Cells(row + 1, 2).value = ticket.Item("baseline_start")
    bd.Cells(row + 1, 3).value = ticket.Item("baseline_finish")
    bd.Cells(row + 2, 1).value = "予定"
    bd.Cells(row + 2, 2).value = ticket.Item("due_assign")
    bd.Cells(row + 2, 3).value = ticket.Item("due_close")
    bd.Cells(row + 0, 5).value = "説明"
    bd.Cells(row + 0, 6).value = ticket.Item("summary")
    bd.Cells(row + 1, 5).value = "見積時間"
    bd.Cells(row + 1, 6).value = ticket.Item("estimatedhours")
    bd.Cells(row + 2, 5).value = "基準時間"
    bd.Cells(row + 2, 6).value = ticket.Item("baseline_cost")
   
    bd.Cells(row + 3, 2).value = "残"
    bd.Cells(row + 3, 3).value = "合計"
    bd.Cells(row + 3, 4).value = "時間"
    bd.Cells(row + 3, 5).value = "計画"
    bd.Cells(row + 3, 6).value = "予定"
    bd.Cells(row + 3, 7).value = "基準"

    bd.Cells(row + 4, 1).NumberFormatLocal = "m/d;@"
    bd.Cells(row + 4, 1).value = ticket.Item("baseline_start")
    bd.Cells(row + 4, 5).value = ticket.Item("baseline_cost")
    bd.Cells(row + 5, 1).NumberFormatLocal = "m/d;@"
    bd.Cells(row + 5, 1).value = ticket.Item("baseline_finish")
    bd.Cells(row + 5, 5).value = 0
   
    bd.Cells(row + 6, 1).NumberFormatLocal = "m/d;@"
    bd.Cells(row + 6, 1).value = ticket.Item("due_assign")
    bd.Cells(row + 6, 6).value = 0
    bd.Cells(row + 7, 1).NumberFormatLocal = "m/d;@"
    bd.Cells(row + 7, 1).value = ticket.Item("due_assign")
    bd.Cells(row + 7, 6).value = ticket.Item("estimatedhours")
   
    bd.Cells(row + 8, 1).NumberFormatLocal = "m/d;@"
    bd.Cells(row + 8, 1).value = ticket.Item("due_close")
    bd.Cells(row + 8, 6).value = 0
    bd.Cells(row + 9, 1).NumberFormatLocal = "m/d;@"
    bd.Cells(row + 9, 1).value = ticket.Item("due_close")
    bd.Cells(row + 9, 6).value = ticket.Item("estimatedhours")
    Dim estimatedhours As Integer
    estimatedhours = ticket.Item("estimatedhours")
    row = row + 10
    Dim t As Collection
    Set t = trac.getWorkHours(id)
    If t.Count = 0 Then
        Exit Function
    End If
    Dim date1 As Date
    date1 = "1900/01/01"
    bd.Cells(row, 1).FormulaR1C1 = "=R[1]C-1"
    bd.Cells(row, 2).FormulaR1C1 = "=RC[1]"
    bd.Cells(row, 3).FormulaR1C1 = "=R[1]C"
    bd.Cells(row, 4).value = estimatedhours
    bd.Cells(row, 8).value = 0
    bd.Cells(row, 7).value = "=R[1]C"
    row = row + 1
    For i = 1 To t.Count
        Dim ct As Collection
        Set ct = t.Item(i)
        Debug.Print ct.Item("time_iso")
        If ct.Item("time_iso") - date1 >= 2# And i > 1 Then
            Debug.Print "二日以上の空きがあるので"
            date1 = ct.Item("time_iso") - 1#
            bd.Cells(row, 1).NumberFormatLocal = "m/d;@"
            bd.Cells(row, 1).value = date1
            bd.Cells(row, 3).FormulaR1C1 = "=R[-1]C"
            bd.Cells(row, 4).FormulaR1C1 = "=R[-1]C"
            bd.Cells(row, 8).FormulaR1C1 = "=R[-1]C"
            bd.Cells(row, 8).FormulaR1C1 = "=R[-1]C"
            bd.Cells(row, 7).FormulaR1C1 = "=R[-1]C"
            row = row + 1
        End If
        date1 = ct.Item("time_iso")
        bd.Cells(row, 1).NumberFormatLocal = "m/d;@"
        bd.Cells(row, 1).value = ct.Item("time_iso")
        bd.Cells(row, 2).value = ct.Item("estimatedhours") - ct.Item("totalhours")
        bd.Cells(row, 3).value = ct.Item("estimatedhours")
        bd.Cells(row, 7).value = ct.Item("baseline_cost")
        bd.Cells(row, 4).value = estimatedhours - ct.Item("totalhours")
        bd.Cells(row, 8).value = ct.Item("totalhours")
        row = row + 1
    Next
    createBurndown = row
End Function

実際にcreateBurndownを呼ぶところは次のようになり，Tracの情報の準備と，どのシートのどこに，どのチケットの情報を取ってくるかを決めて関数を呼ぶだけです．

Sub test()
    Dim user As String, pw As String, URL As String, projectName As String, query As String
    Dim trac As TracXMLRPC
   
    Dim settingSheet As Worksheet
    Set settingSheet = Sheet1
    URL = settingSheet.Cells(2, 3).value
    user = settingSheet.Cells(6, 3).value
    pw = settingSheet.Cells(7, 3).value
    projectName = settingSheet.Cells(3, 3).value
   
    Set trac = New TracXMLRPC
    trac.init URL, projectName, user, pw

    createBurndown trac, Sheet2, 3, 31
   
End Sub

このマクロを動かして作った，前のグラフの元データは次のようになります．

ここに書いてあるコードはVisualBasicTracConnectorIntegrationにサンプルで登録します．

参照

• TracのXMLRPCを拡張してみる
• TracDependencyPlugin
• VisualBasicTracConnectorIntegration

Tracの情報をもとにExcelで作ったレポートをPDF化し，Tracのチケットに添付してしまうところまでを自動化したい．

Excel2007を使用した場合は，ExportAsFixedFormatを使用して簡単にPDFが作成できるということがわかったので，レポートをPDF化し，Tracのチケットに添付してしまおうということでやってみました．まずBase64のエンコードを作ってみました．VBAだとシフトは使えないし，型変換では丸められるしでだいぶ苦労しました．XML-RPCを使いファイルを添付するところまでやってみました．まぁ．レポートの作成は運用でだいぶ違うと思いますので，そのままは使えませんが，VBAの分かる方は参考にしてみてください．

VisualBasicTracConnector　に登録しておきます．

レポートを作成するところはTracXMLRPC.clsを使って進捗報告のレポートを作成する例を参考にしていただくとして，変換のところは

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("/")
    Else
        Debug.Print "Error"
    End If
End Function

Private Function encodeBase64(ByRef buf() As Byte, fileSize As Long) As String
    Debug.Print UBound(buf)
    encodeBase64 = ""
    Dim pos As Long
    For pos = 0 To UBound(buf) - 1 Step 3
        Dim l As Long, l2 As Long
        Dim d(4) As Long
        Dim e(4) As Long
        l = (buf(pos)) * (2 ^ 16) + (buf(pos + 1)) * (2 ^ 8) + (buf(pos + 2))
        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) And 63)
        e(1) = encodeBase64Byte(d(1))
        e(2) = encodeBase64Byte(d(2))
        e(3) = encodeBase64Byte(d(3))
        e(4) = encodeBase64Byte(d(4))
        If fileSize - pos = 2 Then
            e(4) = Asc("=")
        ElseIf fileSize - pos = 3 Then
            e(3) = Asc("=")
            e(4) = Asc("=")
        End If
        encodeBase64 = encodeBase64 + Chr(CByte(e(1))) + Chr(CByte(e(2))) + Chr(CByte(e(3))) + Chr(CByte(e(4)))
    Next
End Function

ファイルを読み込むところは，変換の単位が３文字ごとなので３文字の倍数のバッファを用意しています．トラックとのやり取りはTracHacksで見ていただいたほうがいいでしょうが，追加したところだけ貼り付けておきます．

Public Function putAttachment(id As Long, path As String, fileName As String, description As String) As String
    Dim n As Long, base64 As String, fileSize As Long
    n = FreeFile
    fileSize = FileLen(path)
    Dim buf() As Byte
    ReDim buf(Int((fileSize + 2) / 3) * 3)
    Open path For Binary As #n
        Get #n, , buf
    Close #n
   
    putAttachment = putAttachment_sub(id, fileName, description, encodeBase64(buf, fileSize))
End Function

Public Function putAttachment_sub(id As Long, fileName As String, description As String, data As String) As String
    Dim funcName As String, params As String, dataType As String
    Dim ret As Collection
    funcName = "ticket.update"
    params = _
            "<param><value><i4>" & id & "</i4></value></param>" & vbCrLf & _
            "<param><value><string>" & fileName & "</string></value></param>" & vbCrLf & _
            "<param><value><string>" & description & "</string></value></param>" & vbCrLf & _
            "<param><value><base64>" & data & "</base64></value></param>" & vbCrLf & _
            "<param><value><boolean>1</boolean></value></param>"
'    Debug.Print params
    Set Members = getMember("ticket.putAttachment", params, "string")
    If Members Is Nothing Then
        Exit Function
    End If
    If Members.Length = 0 Then
        Exit Function
    End If
    For i = 0 To Members.Length - 1
        Set Item = Members.Item(i)
        putAttachment_sub = Item.text
'        d.Add name
'        Debug.Print "-" & name & "(" & typeName & ")"
        yield
    Next
End Function

TracXMLRPC.clsを呼ぶところはExportAsFixedFormatを呼んででPDF作ったあとに，putAttachment呼んでいるだけです．

Sub test()
    Dim user As String, pw As String, URL As String, projectName As String, query As String
    Dim devTrac As TracXMLRPC
   
    Dim settingSheet As Worksheet
    Set settingSheet = Sheet1
    URL = settingSheet.Cells(2, 3).value
    user = settingSheet.Cells(6, 3).value
    pw = settingSheet.Cells(7, 3).value
    projectName = settingSheet.Cells(3, 3).value
   
    Set devTrac = New TracXMLRPC
    devTrac.init URL, projectName, user, pw
   
    Dim fileName As String, reportSheet As Worksheet
    Set reportSheet = Application.ActiveWorkbook.Sheets.Item("Report")
    fileName = ActiveWorkbook.path & "\test.pdf"
    reportSheet.ExportAsFixedFormat xlTypePDF, fileName, xlQualityStandard, True, True

    devTrac.putAttachment 1, fileName, "test.pdf", "進捗"
End Sub

今までTrac関係で作ったものの関係をまとめる。

勉強会の発表資料は分かりにくかったのと，Trac関係に一区切りをつけたいなということで，最近は仕事でTrac使うことがないので，テストとかほとんどできてなくて，すべて中途半端ですが、私がやってきたこと（ProjectのVBAは後で登録します）をまとめておきます．

今まで，Tracの問題としてあげられてきた内容をまとめると．

• プロジェクトの親子関係がない
• チケットの粒度が違うものをどうするか
• 項目（カスタムフィールド）が大きく違うものを同じプロジェクトで扱うこと
• 複数のプロジェクトに分割したときの登録，確認，出力方法
• コミットメッセージが一つのプロジェクトにしかつけられないため分割できない

これらを解決するために，私が作ってきたものがどこにからんでくるかということを，次の図にしました．この図ならなんとかわかってもらえるのではないかと

1. InterTracCommitPatch

コミットメッセージを，同じサーバ上の隣のプロジェクトにつけることを可能にします．これにより，今までは，要件定義，工程，実作業，障害などは，同じリポジトリを使う必要があため，どれだけ扱う項目（カスタムフィールド）が違っていたとしても，同じプロジェクトで扱うしか方法がありませんでした．これがあれば，リポジトリの縛りから解放され，プロジェクトを自由に分割することができます．

2. TracDepenecencyPlugin

同じサーバのTracプロジェクト間でチケットの親子関係と，依存関係を扱えるように拡張し，Tracのプロジェクトを分割することが容易になります．カスタムフィールドの入力のところのチェックがまだ追加できてないので，先行チケットを複数指定するときはカンマで区切り，スペースを追加しないとだめなはず．

3. レポート，クエリのHTA

複数のプロジェクトの状況を確認するには，いろいろやらなければならないことが多かったため，これを使用することで，一つのクエリ，レポートの状況を一目で確認できるようにします．いまはTraM（まだ確認してません）があるので必要ないのでしょうか．このHTAは，環境によるのだと思いますが，接続できない未解決の問題があるようです．

4. チケット登録/編集用Excel VBA

XML-RPC経由でチケットの登録と編集を行います．単純に複数のシートに書き込めるようにしただけですが，あれば結構便利です．

5. MS-Project - Trac 連携VBA InterTrac対応版（未公開）

このVBAは，2.のプラグインの情報を元に，ガントチャートが作成でき，先行タスクのところにカッコつきで指定した，四つの依存関係(SS,FS,SF,FF))に対応もしています．作ったものの，仕事で使う機会がなく，デバッグできてないので，公開してません．どの範囲の親子や依存関係を取ってくるかは情報の取得時に設定するため，開発者個人のプロジェクトやレビュープロジェクトを含め内容にすることができます．（MasterTicketsのように，双方向のリンクをDBに保存してないのはそういう理由だったんですが，今となってはあってもよかったのかなぁと思ってます．）

最近出てきたTraMとか含めると，いろいろなところで出ていたTracの問題や，RedMineより劣る点って，解決すると思うんですがどうでしょうか．

TracXMLRPC.clsを使って進捗報告のレポートを作成する例

Tracをプロジェクタ等で見ながらの進捗の報告がゆるされない職場ってまだまだありますよね．そういう場合は，何らかのレポートを作成することになりますが，せっかくXMLRPCでアクセスするクラスモジュールを作ったので，それを使って作ってみました．出力画面は次のようになります．

XMLRPCで接続して各種日付の情報から次の順番でレポートを作成していきます．

1. 期間内にクローズ済みのチケット
2. 作業中のチケット
3. 開始予定のチケット

ちゃんとしたTracのプロジェクトではないので上の例ではわかりにくいと思いますが，その中にはsummary, id, due_assign, due_close, complete, descriptionを二行で追加しています．そのサンプルを次に貼り付けます．

Dim trac As TracXMLRPC
Dim s As Worksheet
Dim owner As String

Function initSheet(dBefore As String, dReport As String, dNext As String) As Integer
    s.Cells(1, 3).value = "作業進捗報告"
    s.Cells(1, 3).HorizontalAlignment = xlCenter
    s.Cells(2, 4).value = "報告日：" & dReport
    s.Cells(2, 4).HorizontalAlignment = xlRight
    s.Cells(3, 4).value = "期間：" & dBefore & " - " & dNext
    s.Cells(3, 4).HorizontalAlignment = xlRight
    s.Cells(4, 4).value = "報告者："
    s.Cells(4, 4).HorizontalAlignment = xlRight
    initSheet = 5
    s.Range(s.Rows(initSheet), s.Rows(65536)).Delete xlUp
End Function

Public Function importClosedTickets(row As Integer, pre As String, dStart As String) As Integer
    Dim t1 As Collection
    Dim query As String
    query = "<string>status=closed&amp;owner=" & owner & "</string>"
    Set t1 = trac.queryTicket(query)
    Dim no As Integer
    no = 1
   
    On Error Resume Next
    For Each t In t1
        due_assign = due_close = complete = ""
        due_assign = t.Item("due_assign")
        due_close = t.Item("due_close")
        complete = t.Item("complete")
        If due_close >= dStart Then '前回報告日以後にクローズされているなら
            s.Cells(row, 2).value = pre & no & ". " & t.Item("summary") & "(" & t.Item("id") & ")"
            work = due_assign & "-" & due_close
            If complete <> "" Then work = work & "(" & complete & "%)"
            s.Cells(row, 4).value = work
            s.Cells(row, 4).HorizontalAlignment = xlRight
            row = row + 1
            work = ""
            work = t.Item("description")
            work = Replace(work, "[[BR]]", vbCrLf)
            s.Cells(row, 3).value = work
            row = row + 1
            no = no + 1
        End If
    Next
    On Error GoTo 0
    importClosedTickets = row
End Function

Public Function importWorkingTickets(row As Integer, pre As String, dReport As String, dEnd As String) As Integer
    Dim t1 As Collection
    Dim query As String
    query = "<string>status!=closed&amp;owner=" & owner & "</string>"
    Set t1 = trac.queryTicket(query)
    Dim no As Integer
    no = 1
   
    On Error Resume Next
    For Each t In t1
        due_assign = due_close = complete = ""
        due_assign = t.Item("due_assign")
        due_close = t.Item("due_close")
        complete = t.Item("complete")
        If due_assign <= dReport Then '報告日以前に開始しているなら
            s.Cells(row, 2).value = pre & no & ". " & t.Item("summary") & "(" & t.Item("id") & ")"
            work = due_assign & "-" & due_close
            If complete <> "" Then work = work & "(" & complete & "%)"
            s.Cells(row, 4).value = work
            s.Cells(row, 4).HorizontalAlignment = xlRight
            row = row + 1
            work = ""
            work = t.Item("description")
            work = Replace(work, "[[BR]]", vbCrLf)
            s.Cells(row, 3).value = work
            row = row + 1
            no = no + 1
        End If
    Next
    On Error GoTo 0
    importWorkingTickets = row
End Function

Public Function importDueAssignTickets(row As Integer, pre As String, dReport As String, dEnd As String) As Integer
    Dim t1 As Collection
    Dim query As String
    query = "<string>status!=closed&amp;owner=" & owner & "</string>"
    Set t1 = trac.queryTicket(query)
    Dim no As Integer
    no = 1
   
    On Error Resume Next
    For Each t In t1
        due_assign = due_close = complete = ""
        due_assign = t.Item("due_assign")
        due_close = t.Item("due_close")
        complete = t.Item("complete")
        If due_assign > dReport And due_assign <= dEnd Then '報告日以後で次回報告以前に開始する予定なら
            s.Cells(row, 2).value = pre & no & ". " & t.Item("summary") & "(" & t.Item("id") & ")"
            work = due_assign & "-" & due_close
            If complete <> "" Then work = work & "(" & complete & "%)"
            s.Cells(row, 4).value = work
            s.Cells(row, 4).HorizontalAlignment = xlRight
            row = row + 1
            work = ""
            work = t.Item("description")
            work = Replace(work, "[[BR]]", vbCrLf)
            s.Cells(row, 3).value = work
            row = row + 1
            no = no + 1
        End If
    Next
    On Error GoTo 0
    importDueAssignTickets = row
End Function

Sub createReport()
    '進捗報告という名前のシートを変数に設定する．
    Set s = Application.ActiveWorkbook.Sheets.Item("進捗報告")
    Dim dBefore As String
    Dim dReport As String
    Dim dNext As String
    Dim row As Integer
   
    dBefore = "2009/05/22" '前回報告日
    dReport = "2009/05/29" '報告日
    dNext = "2009/06/05" '次回報告日
    owner = "u-z" '担当者
    Set trac = New TracXMLRPC
    trac.init "http://localhost/trac", "test3", "admin", "admin"
    row = initSheet(dBefore, dReport, dNext) '
    s.Cells(row, 1).value = "1. 期間内にクローズ済みのチケット"
    row = importClosedTickets(row + 1, "1.", dBefore)
    s.Cells(row, 1).value = "2. 作業中のチケット"
    row = importWorkingTickets(row + 1, "2.", dReport, dNext)
    s.Cells(row, 1).value = "3. 開始予定のチケット"
    row = importDueAssignTickets(row + 1, "3.", dReport, dNext)
    s.Cells(row + 1, 1).value = "以上"
End Sub

確認手順

1. あたらしいExcelファイルを作成
2. VBEditorでTracXMLRPC.clsをインポート
3. 上のサンプルをどこか（TishWorkBookとか）に貼り付け
4. どれかのシート名を”進捗報告”に変更するか追加する
5. 日付やowner等を適切に変更
6. createReportを実行

でどうでしょう．

TracXMLRPC.clsの使い方２

TracXMLRPC.clsをインポートして，どこでもいいので次のコードを追加する．testを実行すると，Tracに接続し，マイルストーンの一覧を表示，チケットを追加し，内容を表示し，カスタムフィールドの進捗率を変更するサンプルです．TracXMLRPCにはデバッグのprintが残っているのでわかりにくいですが，イミディエイトに結果が表示されます．

Sub test()
    Dim trac As TracXMLRPC
    Set trac = New TracXMLRPC
    Dim attr As Collection
    Dim ticket As Collection
    Set attr = New Collection
    Dim id As Long
    '初期化
    trac.init "http://localhost/trac", "SampleProject", "admin", "admin"
    'マイルストーンなどのデータはすでにとられている．
    Debug.Print vbCrLf & "マイルストーンを表示する"
    For Each ms In trac.milestone
        Debug.Print "    " & ms.Item("name")
    Next
    '進捗率だけ設定してチケットを追加
    attr.Add "50", "complete"
    id = trac.createTicket("VBAから追加", "詳細は．．．[[BR]]改行", attr, False)
    Debug.Print "チケット id=" & id & " で追加しました"
   
    '登録したチケットの情報を取得する
    Set ticket = trac.getTicket(CStr(id))
    For Each field In ticket
        Debug.Print field
    Next
    'これだけではわからないのでcompleteをとってみる
    Debug.Print "summary=" & ticket.Item("summary")
    Debug.Print "complete=" & ticket.Item("complete")
    Debug.Print "description=" & ticket.Item("description")
    '進捗率を変更してみる．
    Set attr = New Collection
    attr.Add "100", "complete"
    Set ticket = trac.updateTicket(id, "コメントもつけられる", attr, False)
    Debug.Print "変更された進捗率は " & ticket.Item("complete")
End Sub