XMLRPC

2011年10月31日 (月)

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

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


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

Tracconfig1

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

Tracconfig3

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

Tracconfig4

変更結果の確認
Tracconfig5

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

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」をダウンロード

| | コメント (0) | トラックバック (0)

2011年10月24日 (月)

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

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

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


| | コメント (0) | トラックバック (0)

2010年2月12日 (金)

TracのチケットをOutlookに取り込んで表示する.

 勤務地変更になって,4時間/日程度通勤時間にとられると,更新する時間が無くなってしまいましたが,Tracは使っていないというわけではありませんでした.今回はお手伝い中のプロジェクトで,Tracを自由に使ってもらった結果Trac-Outlook連携が必要になりましたのでその報告です.私が会議資料を作るためのチケットを登録しているのを見たからか,数分で終わる作業がチケット化されてしまうようになった.(こんなこと説明したくないので,いやになってしまいますが,)Outlookのタスクとアポイントの使い方を説明した.ただ,何かと共有フォルダとExcelが出てくるようなところなので,このままにしておくとTracを使わなくなりそうなので,TracのチケットをOutlookに取り込んで,そこだけ見ておけば良いということにしました.
自宅で使うために,TracHacksを見れるように少し機能を落として,TracのXML-RPCの標準機能の範囲でできるようにした.細かなクエリができるわけではないので,ownerが一致する全チケットを取ってきて,そのすべてのチケットをない場合は登録し,存在していれば更新をするようにしました.毎回すべて取ってくるので一日一回の更新ぐらいになるのかなと思います.また,ticket.queryメソッドは100件しか取得できない制限はあるので,それを超えたい場合はXML-RPCを拡張しなければならない.(かおるんさんにご指摘いただきました)制限の解除方法についてはこの記事を参考にしてください.

取得した後の画面はこんな感じです.

Outlook

後はソースです.次のものは標準モジュールのどこかに追加してください.これはTracHacksとローカルのTracLightningに接続する例です.TracHacksにはプロジェクト名はないので,””です.後はユーザ登録しておかないと,使えないのでコメントにでもしておいてください.initの引数のユーザ名,パスワード,オーナーは分かっていただけるとして,プロジェクトの識別名は,URL をそのまま使いたくないのでタスクの名称がそのTracのプロジェクトと一致するかを見るために使っています.重複しなければ適当につけてください.あとは,適当なボタンを追加してこの関数を割り当てればいいでしょう.

Sub ImportTickets()
    Dim c As TracOutlookConnector
    Set c = New TracOutlookConnector
    c.init "http://trac-hacks.org", "", ユーザ名, パスワード, オーナー名, プロジェクトの識別名
    c.update
   
    Dim c2 As TracOutlookConnector
    Set c2 = New TracOutlookConnector
    c2.init "http://192.168.1.13/trac", "Test1", "admin", "admin", "admin", "Test1"
    c2.update
   
End Sub

今回作ったクラスモジュールのTracOutlookConnector.clsです.XML-RPCのticket.queryの結果をOutlookのTask(TODO)に設定していきます.

※ initにownerが正常に設定できない問題がありましたので修正しました.m(_ _)m

'Copyright (c) 2009 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.

Dim Trac As TracXMLRPC
Dim prjID As String
Dim owner As String

Private Sub Class_Initialize()
End Sub

Public Function init(URL As String, projectName As String, user As String, pw As String, ownerName As String, projectID As String)
    Set Trac = New TracXMLRPC
    Trac.init URL, projectName, user, pw
    prjID = projectID
    owner = ownerName
End Function

Sub update()
    Dim addr As String
    Dim i As TaskItem
    Dim tracItem As TaskItem
    addr = Trac.URL & "/ticket/"
   
    Set objNamespace = Application.GetNamespace("MAPI")
    Dim objFolder As MAPIFolder
    Set objFolder = objNamespace.GetDefaultFolder(olFolderTasks)
    Set colTasks = objFolder.Items
   
    Dim c As Collection
'    Set c = trac.queryTicket("<string>status!=closed&amp;owner=" & owner & "</string>")
    Set c = Trac.queryTicket("<string>owner=" & owner & "</string>")
    Set fields = Trac.field()
    If Not c Is Nothing Then
        '取得できたチケットについて情報を更新する
        For Each t In c
            Dim f As Boolean
            Dim tId As String
            'チケットとTaskが一致するかを比較するための文字列を作る.
            tId = prjID & ":#" & t.Item("id") & " " 'スペースを入れておかないと前方一致で引っかかることがある.
            f = False
            
            For j = 1 To colTasks.Count
                Set i = colTasks.Item(j)
                If InStr(1, i.Subject, tId) = 1 Then
                    Set tracItem = i
                    f = True
                    Exit For
                End If
            Next
            If f = False Then
                Set tracItem = Application.CreateItem(olTaskItem)
            End If
            On Error Resume Next
            tracItem.StartDate = t.Item("due_assign")
            tracItem.DueDate = t.Item("due_close")
            On Error GoTo 0
            
            If tracItem.StartDate <> #1/1/4501# And tracItem.StartDate <> #1/1/4501# Then
                tracItem.Subject = tId & _
                            Format(tracItem.StartDate, " MM/DD-") & _
                            Format(tracItem.DueDate, "MM/DD ") & _
                            t.Item("summary")
            Else
                tracItem.Subject = tId & " " & t.Item("summary")
            End If
            
            tracItem.Body = addr & t.Item("id") & vbCrLf & _
                            "Do not edit this task item." & vbCrLf & _
                            t.Item("description")
            
            If t.Item("status") = "closed" Then
                tracItem.PercentComplete = 100
            Else
                tracItem.PercentComplete = 0
                On Error Resume Next
                tracItem.PercentComplete = t.Item("complete")
                On Error GoTo 0
            End If
            tracItem.Save
        Next
    End If
   
End Sub

いつものクラスモジュールのTracXMLRPC.clsです

'Copyright (c) 2009 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.

Dim m_URL As String
Dim m_projectName As String
Dim m_user As String
Dim m_pw As String

Dim m_milestone As Collection
Dim m_status As Collection
Dim m_version As Collection
Dim m_component As Collection
Dim m_priority As Collection
Dim m_resolution As Collection
Dim m_severity As Collection
Dim m_type As Collection
Dim m_fieldN As Collection
Dim m_fieldL As Collection
Dim m_initialized As Boolean

Dim m_timeDifference As Double

Private Sub Class_Initialize()
    m_timeDifference = 9#
    m_initialized = False
End Sub

'クラスを初期化します.各引数は次のように指定してください
'接続できない場合とかはここでエラーが発生します.
'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)
    m_projectName = projectName
    m_URL = URL
    If m_projectName <> "" Then
        m_URL = m_URL & "/" & m_projectName
    End If
    m_user = user
    m_pw = pw
'    getStringArray m_type, "type"
'    getStringArray m_status, "status"
'    getStructArray m_resolution, "resolution"
'    getStructArray m_milestone, "milestone"
'    getStructArray m_version, "version"
'    getStructArray m_component, "component"
'    getStringArray m_priority, "priority"
'    getStringArray m_severity, "severity"
'    getTicketFields m_fieldN, m_fieldL, "field", "ticket.getTicketFields"
    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_fieldN = Nothing
    Set m_fieldL = Nothing
    m_initialized = True
End Sub

'IDを指定してチケットの情報を取得します
Public Function getTicket(id As String) As Collection
    Set getTicket = getStruct("ticket.get", id, "int")
    getTicket.Add id, "id"
End Function

Private Function getStruct_sub(method As String, params As String) As Collection
    Dim d As Collection
    Set Members = getMember(method, params, "member")
    If Members Is Nothing Or Members.Length = 0 Then '何も戻ってこなかったら
        Set getStruct_sub = Nothing
        Exit Function
    End If
    Set d = New Collection
    Dim n As String, v As String
    For i = 0 To Members.Length - 1
        Set oNodeList = Members.Item(i).ChildNodes
        If oNodeList.Length = 2 Then
            n = oNodeList(0).text '名
            v = oNodeList(1).text '値
            nn = oNodeList(1).ChildNodes(0).nodeName 'ノード名
            If nn = "dateTime.iso8601" Then
                '日付でも値が入ってない場合はここに入ってこないうえに値に0が入ってる
                v = convertDateStr(v) '日付を修正
            End If
            d.Add v, n 'コレクションに値を追加
'            Debug.Print "    " & n & "=" & v
        End If
        yield
    Next
    Set getStruct_sub = d
End Function

'TODO:publiv->privateに変更したが問題無いか確認
Private Function getStruct(method As String, name As String, dataType As String) As Collection
    Dim params As String
    params = "<param><value><" & dataType & ">" & name & "</" & dataType & "></value></param>"
    Set getStruct = getStruct_sub(method, params)
End Function

'milestone等の情報を取得します.指定できるのは次のものです.
'"resolution","milestone","version","component","priority","severity"
Private Sub getStructArray(ByRef d As Collection, typeName As String)
    getStructArray_Sub d, typeName, "ticket." & typeName & ".getAll", ""
End Sub

Private Sub getStructArray_Sub(ByRef d As Collection, typeName As String, method As String, params As String)
    Dim name As String
    Set d = New Collection
    Set Members = getMember(method, params, "string")
    If Members Is Nothing Or Members.Length = 0 Then
        Exit Sub
    End If
    For i = 0 To Members.Length - 1
        name = Members.Item(i).ChildNodes(0).text
        Dim c As Collection
'        Debug.Print "s--" & name & "(" & typeName & ")"
        Set c = getStruct("ticket." & typeName & ".get", name, "string") 'なにも得られなかった場合はnameがそのまま戻ってくる
        If c Is Nothing Then
            d.Add name, name
        Else
            d.Add c, name
        End If
'        Debug.Print "e--" & name
        yield
    Next
End Sub

'文字列コレクションを返します.typeNameに指定できるのは次のものです.
'"type","status"
Private Sub getStringArray(ByRef d As Collection, typeName As String)
    getStringArray_Sub d, typeName, "ticket." & typeName & ".getAll"
End Sub

Private Sub getStringArray_Sub(ByRef d As Collection, typeName As String, method As String)
    Dim name As String
    Set d = New Collection
    Set Members = getMember(method, "", "string")
    If Members Is Nothing Then
        Exit Sub
    End If
    If Members.Length = 0 Then
        Exit Sub
    End If
    For i = 0 To Members.Length - 1
        Set Item = Members.Item(i)
        name = Item.text
        d.Add name
'        Debug.Print "-" & name & "(" & typeName & ")"
        yield
    Next
End Sub

'ticket.getTicketFields()でTicketFieldを取得するために使用します.
Private Sub getTicketFields(ByRef d As Collection, ByRef e As Collection, typeName As String, method As String)
    Set d = New Collection
    Set e = New Collection
    Set Members = getMember(method, "", "struct")
    If Members Is Nothing Then
        Exit Sub
    End If
    If Members.Length = 0 Then
        Exit Sub
    End If
    Dim c As Collection
   
    Set c = New Collection
   
    For i = 0 To Members.Length - 1
        Dim n As String, v As String
       
        Set c = New Collection
        Set oNodeList = Members.Item(i).ChildNodes 'member
       
        For j = 0 To oNodeList.Length - 1
            Set oNodeList2 = oNodeList.Item(j).ChildNodes
            If oNodeList2.Length = 2 Then
                n = oNodeList2(0).text '名
                v = oNodeList2(1).text '値
                c.Add v, n 'コレクションに値を追加
'                Debug.Print "    " & n & "=" & v
            End If
            yield
        Next
'        Debug.Print "=== name=" & c.Item("name") & " label=" & c.Item("label")
        d.Add c, c.Item("name")
        e.Add c, c.Item("label")
        yield
    Next
End Sub

'XMLRPCでのstructをVBのCollectionから作成します.
Public Function createStruct(arrayMember As Collection) As String
    Dim structString As String
    Dim name As Variant
    If arrayMember Is Nothing Then
        Exit Function
    End If
    structString = "<struct>" + vbCrLf
   
    On Error Resume Next
    For Each name In m_fieldN
        Dim fieldName As String, value As String
        fieldName = name.Item("name")
'        If fieldName <> "id" Then
            structString = structString + _
                "<member>" + _
                    "<name>" + fieldName + "</name>" + _
                    "<value>" + arrayMember.Item(fieldName) + "</value>" + _
                "</member>" + vbCrLf
'        End If
    Next
    If structString = "<struct>" Then
        structString = ""
    Else
        structString = structString + "</struct>"
    End If
'    Debug.Print structString
    createStruct = structString
End Function

Public Function createTicket(summary As String, description As String, attributes As Collection, notify As Boolean) As Long
'int ticket.create(string summary, string description, struct attributes={}, boolean notify=False)
'Create a new ticket, returning the ticket ID.
    Dim funcName As String, params As String, dataType As String
    funcName = "ticket.create"
    dataType = "int"
    createTicket = 0
    Do
        params = _
            "<param><value><string>" & summary & "</string></value></param>" & vbCrLf & _
            "<param><value><string>" & description & "</string></value></param>" & vbCrLf & _
            "<param><value>" & vbCrLf & _
                createStruct(attributes) & vbCrLf & _
            "</value></param>" & vbCrLf & _
            "<param><value><boolean>" & CStr(Abs(CInt(notify))) & "</boolean></value></param>"
'        Debug.Print params
        Set Members = getMember(funcName, params, dataType)
        For i = 0 To Members.Length - 1
            Set oNodeList = Members.Item(i).ChildNodes
            createTicket = CLng(oNodeList(0).text)
            yield
        Next
        Exit Do
    Loop
End Function

Public Function updateTicket(id As Long, comment As String, attributes As Collection, notify As Boolean) As Collection
'array ticket.update(int id, string comment, struct attributes={}, boolean notify=False)
'Update a ticket, returning the new ticket in the same form as getTicket().
    Dim funcName As String, params As String, dataType As String
    funcName = "ticket.update"
    params = _
            "<param><value><i4>" & id & "</i4></value></param>" & vbCrLf & _
            "<param><value><string>" & comment & "</string></value></param>" & vbCrLf & _
            "<param><value>" & vbCrLf & _
                createStruct(attributes) & vbCrLf & _
            "</value></param>" & vbCrLf & _
            "<param><value><boolean>" & CStr(Abs(CInt(notify))) & "</boolean></value></param>"
'    Debug.Print params
    Set updateTicket = getStruct_sub(funcName, params)
End Function

'チケット(Collection)のCollectionを返します.
'第二引数を削除した.
'Public Function queryTicket(query As String, enableTree As Boolean) As Collection
Public Function queryTicket(query As String) As Collection
    Dim funcName As String, queryString As String, dataType As String
    funcName = "ticket.query"
    dataType = "int"
    Set queryTicket = New Collection
    Dim ticketId As String
    ticketId = "0"
    Do
        If query = "" Then
            queryString = ""
        Else
            queryString = "<param>" & query & "</param>"
        End If
        Set Members = getMember(funcName, queryString, dataType)
        For i = 0 To Members.Length - 1
            Set oNodeList = Members.Item(i).ChildNodes
            ticketId = oNodeList(0).text
            Set ti = getTicket(ticketId)
            queryTicket.Add ti, ticketId
            yield
        Next
        Exit Do
    Loop
End Function

'Tracに接続してレスポンスを得て,指定したタグの一覧を返します.
Private Function getMember(method As String, params As String, tag As String) As Variant
'    Dim xmlSv As MSXML2.xmlHttp
'    Set xmlSv = New MSXML2.xmlHttp
'参照設定が無くても使えるようにする
    Dim xmlSv As Variant
    Set xmlSv = CreateObject("MSXML2.XMLHTTP")
    Dim addr As String
   
    addr = Me.URL() & "/login/xmlrpc"
   
    xmlSv.Open "POST", addr, False, m_user, m_pw
    xmlSv.setRequestHeader "Method", "POST " & addr & " HTTP/1.1"
    xmlSv.setRequestHeader "Content-Type", "text/xml"
   
    On Error GoTo conerr
   
    If method <> "" Then
        param = "<?xml version='1.0' encoding='utf-8'?>" & vbNewLine & _
            "<methodCall>" & _
            "   <methodName>" & method & "</methodName>" & _
            "   <params>" & params & "</params>" & _
            "</methodCall>"
        Call xmlSv.send(param)
        '"fault"
    End If
    On Error GoTo 0
    If checkError(xmlSv) = False Then
        Set getMember = Nothing
        Exit Function
    End If
    Set getMember = xmlSv.responseXML.getElementsByTagName(tag)
    Exit Function
conerr:
    err.Raise vbObjectError + 516, , "Con not connect server"
End Function

'Responseがエラーかどうかを判断します。
'TODO:確認
Private Function checkError(xmlSv As Variant) As Boolean
    checkError = False
    Set Members = xmlSv.responseXML.getElementsByTagName("fault")
    Dim errorMessage As String
    errorMessage = ""
    checkError = False
    If xmlSv.status <= 100 Or xmlSv.status > 200 Then
        '認証に失敗したとかHTTPにアクセスするときまでの問題の処理
        err.Raise vbObjectError + 513, , "Error:" & _
            xmlSv.statusText & "(" & xmlSv.status & ")"
    ElseIf Members.Length = 0 Then
        'faultが無かった場合はちゃんとXMLでレスポンスがあったか確認します.
        If xmlSv.responseXML.getElementsByTagName("methodResponse").Length > 0 Then
            checkError = True
            Exit Function
        End If
        err.Raise vbObjectError + 514, , "Not an XML response."
    Else
        'faultがあった場合エラーメッセージをまとめます
        Set Members = xmlSv.responseXML.getElementsByTagName("member")
        For i = 0 To Members.Length - 1
            Set oNodeList = Members.Item(i).ChildNodes
            If oNodeList.Item(0).text = "faultCode" Then
                errorMessage = errorMessage & "Code=" & oNodeList.Item(1).text
            End If
            If oNodeList.Item(0).text = "faultString" Then
                errorMessage = errorMessage & ":" & oNodeList.Item(1).text
            End If
            yield
        Next
    End If
    If errorMessage <> "" Then
'        MsgBox errorMessage
        err.Raise vbObjectError + 515, , errorMessage
    End If
End Function

'時間を文字列の時間に変換します
'TODO:時差は9時間を固定で入れているのでシステムの設定からとる
Private Function convertDateStr(text As String) As String
'20090317T16:10:12  なので+9Hしないとだめ
    Dim d As Date
    If text = "0" Then '終了日が入っていない場合はなぜか0がくる
        convertDateStr = ""
        Exit Function
    End If
    If Len(text) <> 17 Then
        '正規表現を使うのはめんどくさいので長さだけを見る
        convertDateStr = ""
        err.Raise vbObjectError + 515, , "Error: Date format is wrong (" & text & "). Check the XMLRPC responses."
        Exit Function
    End If
    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_timeDifference, d)
   
    convertDateStr = Format(d, "yyyy/mm/dd h:m:s")
End Function

'時間を文字列の時間に変換します
'TODO:時差は9時間を固定で入れているのでシステムの設定からとる
Private Function convertDate(text As String) As Date
'20090317T16:10:12  なので+9Hしないとだめ
    Dim d As Date
    If text = "0" Then '終了日が入っていない場合はなぜか0がくる
        convertDate = ""
        Exit Function
    End If
    If Len(text) <> 17 Then
        '正規表現を使うのはめんどくさいので長さだけを見る
        convertDate = ""
        err.Raise vbObjectError + 515, , "Error: Date format is wrong (" & text & "). Check the XMLRPC responses."
        Exit Function
    End If
    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_timeDifference, d)
   
    convertDate = d
End Function

Public Property Get milestone() As Collection
    Set milestone = m_milestone
    If m_milestone Is Nothing Then
        getStructArray m_milestone, "milestone"
    End If
    Set milestone = m_milestone
End Property

Public Property Get version() As Collection
    Set version = m_version
    If m_version Is Nothing Then
        getStructArray m_version, "version"
    End If
    Set version = m_version
End Property

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

Public Property Get status() As Collection
    If m_status Is Nothing Then
        getStringArray m_status, "status"
    End If
    Set status = m_status
End Property

Public Property Get component() As Collection
    If m_component Is Nothing Then
        getStructArray m_component, "component"
    End If
    Set component = m_component
End Property

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

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

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

Public Property Get field() As Collection
    If m_fieldN Is Nothing Then
        getTicketFields m_fieldN, m_fieldL, "field", "ticket.getTicketFields"
    End If
    Set field = m_fieldN
End Property

Public Property Get URL() As String
    URL = m_URL
End Property
Public Property Get projectName() As String
    projectName = m_projectName
End Property

Public Property Get initialized() As Boolean
    initialized = m_initialized
End Property

Private Sub yield()
    DoEvents
End Sub

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.putAttachment"
    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(funcName, 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

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
    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

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

ZIP化した「Outlook.zip」をダウンロード  を添付しておきます.

※ ownerが正常に設定できない問題がありましたので修正したものを再アップしました.

| | コメント (4) | トラックバック (1)

2009年10月18日 (日)

ユーザ名を漢字で表示するために,Tracユーザの一覧をXMLRPCで取得する

MS-Project連携やTracの情報からレポートを作るときに,ユーザ名をちゃんとした漢字で出したいので作ってみました.

TracCompleteUserPluginのCompleteUserWeb.process_requestのSQLを拝借して来ると簡単に出来ました.IXMLRPCHandlerをインプリしたクラスにこんな感じで追加するだけ.追加方法は TracのXMLRPCを拡張してみる を参照してください.

    def xmlrpc_methods(self):
        yield ('TICKET_VIEW', ((list, ),), self.getUsers)

    def getUsers(self, req):
        db = self.env.get_db_cnx()
        cursor = db.cursor()
        sql = "SELECT s.sid, sa.value FROM session s left outer join session_attribute sa ON s.sid = sa.sid AND sa.name = 'name' WHERE s.authenticated = 1"
        cursor.execute(sql)
        result = []
        for sid, value in cursor:
            d={}
            d['id']=sid
            if value == None:
                value = ""
            d['name']=value
            result.append(d);
        return result

| | コメント (0) | トラックバック (0)

2009年10月13日 (火)

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

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

バーンダウンチャート

Burndown01

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

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

Burndown02

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

参照

| | コメント (0) | トラックバック (0)

2009年10月12日 (月)

TracのXMLRPCを拡張してみる

レポートの登録までできるようになったので,いろいろなレポートをつくろうということで,ガントチャートの作成時の効率化や,バーンダウンチャートを作成するためにTracを拡張してみました.そのメモです.

やるべきことは

1. IXMLRPCHandlerをインプリしたクラスを作る

XMLRPCプラグインのticket.pyとWorklogプラグインのxmlrpc.pyを参照

2. xmlrpc_methodsにメソッドを追加と必要なメソッド追加

(マップ型の)リストを返す,引数がチケット番号(int)のgetWorkHoursメソッドを追加するために次のようにしてメソッドを追加する.

    def __init__(self):
        pass

    def xmlrpc_namespace(self):
        return 'dependency'

    def xmlrpc_methods(self):
        yield ('TICKET_VIEW', ((list, int),), self.getWorkHours)

3. 実際のメソッドを追加

時間関連のカスタムフィールドを変更時間が一致したものを1レコードにまとめて返すようにする.

ticket.pyのgetRecentChangesを参考にすると,ふつうにSQLは実行できそう.今回は権限はTICKET_VIEWなのでSELECTだけなら問題ないでしょう.問題となるのはNoneがあるとエラーになるので,JOINを使う場合は要注意.Excelで使うことしか考えていないので,””を返すようにしました.

    def getWorkHours(self, req, id):
        """Returns a table of changetime records"""
        #
        db = self.env.get_db_cnx()
        cursor = db.cursor()
        sql="SELECT DISTINCT t.time, t1.newvalue, t2.newvalue, t3.newvalue FROM ticket_change t"
        sql = sql + " LEFT JOIN ticket_change t1 ON t1.time = t.time AND t1.field='totalhours'"
        sql = sql + " LEFT JOIN ticket_change t2 ON t2.time = t.time AND t2.field='estimatedhours'"
        sql = sql + " LEFT JOIN ticket_change t3 ON t3.time = t.time AND t3.field='baseline_cost'"
        sql = sql + " WHERE t.ticket='%s'" % id
        sql = sql + " AND (t.field='totalhours' OR  t.field='estimatedhours' OR  t.field='baseline_cost')"
        #sql = sql + " GROUP BY t.time"
        cursor.execute(sql)
        result = []
        totalhours=""
        estimatedhours=""
        baseline_cost=""
        for row in cursor:
            d={}
            d['time']=row[0]
            d['time_iso']=xmlrpclib.DateTime(datetime.datetime.fromtimestamp(row[0]))
            if row[1] == None:
                d['totalhours']=totalhours
            else:
                d['totalhours']=row[1]
                totalhours=row[1]
            if row[2] == None:
                d['estimatedhours']=estimatedhours
            else:
                d['estimatedhours']=row[2]
                estimatedhours=row[2]
            if row[3] == None:
                d['baseline_cost']=baseline_cost
            else:
                d['baseline_cost']=row[3]
                baseline_cost=row[3]
            if totalhours != "":
                result.append(d)
        return result

その他の参照ページ

XMLRPCの拡張はすごく簡単.できるだけいらないデータ流さないようにとか考えると,積極的に拡張していってもいいのかなと思います.

| | コメント (0) | トラックバック (0)

2009年9月27日 (日)

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

ファイルを読み込むところは,変換の単位が3文字ごとなので3文字の倍数のバッファを用意しています.トラックとのやり取りは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

| | コメント (0) | トラックバック (0)

2009年8月23日 (日)

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

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

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

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

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

Multitracdep_3

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より劣る点って,解決すると思うんですがどうでしょうか.

| | コメント (0) | トラックバック (0)

2009年5月29日 (金)

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

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

Tracreport

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を実行

でどうでしょう.

| | コメント (0) | トラックバック (0)

2009年5月27日 (水)

TracXMLRPC.clsの使い方2

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

| | コメント (0) | トラックバック (0)