« VBAでXMLRPCを汎用的に修正してTrac連携をそれに合わせて修正した | トップページ | メールで受け取ったファイルをSVNに登録する »

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

|

« VBAでXMLRPCを汎用的に修正してTrac連携をそれに合わせて修正した | トップページ | メールで受け取ったファイルをSVNに登録する »

Trac」カテゴリの記事

Excel」カテゴリの記事

XMLRPC」カテゴリの記事

コメント

コメントを書く



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


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



トラックバック


この記事へのトラックバック一覧です: TracのXMLRPCを使ったExcelのマクロでmilestoneなどの設定を取得/更新する:

« VBAでXMLRPCを汎用的に修正してTrac連携をそれに合わせて修正した | トップページ | メールで受け取ったファイルをSVNに登録する »