メールで受け取ったファイルをSVNに登録する

まぁあんまり困る人はいないでしょうが、社外から社内へのアクセス方法がほぼメールだけとかに制限されている会社ってありますよね。メールで受信したファイルをSVNに自動で登録する仕組みを作ってみました。いつものように超プロトタイプレベルですので、自分で何とかできる人だけ参考にしてみて下さい。

大体受け取るメールというのはこういった形のものを想定しています。

TO:特別に用意したアドレスがおすすめ

SUB:svn-commit)120120進捗報告資料を送信します。

BODY: ProjectName:SampleProject

Path:/120120

Comment:refs #1 進捗報告資料を送信します。

メールのタイトルの先頭に"svn-commit"が入っていて、メールの本文にリポジトリの情報を引き出すためのプロジェクト名「ProjectName:」が指定していて,リポジトリ内の保存先のフォルダを「Path:」で指定し、,「Comment:」でコミット時のメッセージを書かいてあり、一つ以上の添付ファイルがついているメールに対しての未処理を行います。プロジェクト名とかメールアドレスはInitTracUsersで、プロジェクト名はInitTracReposで設定されているものである必要があり、リポジトリはチェックアウト済でなければなりません。 また、保存先に指定するパスは最低限1階層は指定してください。（svn addで面倒なことになるので、そうしてます）

ファイルとしては次の三つです
1. SVNUpdate.bas

「SVNUpdate.bas」をダウンロード

2. SVNClient.cls

「SVNClient.cls」をダウンロード

3. CommandLauncher.cls

「CommandLauncher.cls」をダウンロード

さすがにOutlookなので、ソースをそのまま貼り付けてもうれしい人もいないと思うのでファイルにしてますので、それをダウンロードしてインポートしてください。

その他の修正箇所ですが、まずは、
ThisOutlookSessionのApplication_NewMailExを次のようにしてください。

'メールを受信したとき
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim col As Variant
    InitTracUsers
    InitTracRepos

    '複数受信したときはカンマ区切りでメールのIDが入ってくる
    If InStr(1, EntryIDCollection, ",") = 0 Then
        Set col = New Collection
        col.Add EntryIDCollection
    Else
        col = Split(EntryIDCollection, ",")
    End If
    For Each msgId In col
        受信したメールの処理 msgId
    Next
End Sub

次はSVNUpdateのInitTracUsersとInitTracReposを適切に書き換えてください。

Public Sub InitTracUsers()
    Dim c As Collection
    Set m_TracUsers = New Collection
    Set c = New Collection
    c.Add "admin", "name"
    c.Add "admin", "password"
    m_TracUsers.Add c, "admin@example.com"
    Set c = New Collection
    c.Add "admin2", "name"
    c.Add "admin2", "password"
    m_TracUsers.Add c, "admin2@example.com"
End Sub

Public Sub InitTracRepos()
    Dim c As Collection
    Set m_TracRepos = New Collection
    Set c = New Collection
    c.Add "D:\SVN\SampleProject", "WorkingCopy"
    c.Add "http://localhost/svn/SampleProject", "URL"
    m_TracRepos.Add c, "SampleProject"
End Sub

あとは、SVNUpdateのsvn_commitの中にSVNのファイル名が書いてありますのでそこを書き換えておいてください

    Dim colUser As Collection
    Set colUser = m_TracUsers.Item(oMsg.SenderEmailAddress)
    m_svn.init "c:\TracLight\CollabNetSVN\svn.exe", colUser.Item("name"), colUser.Item("password")
    m_svn.Update svnRoot

次は上で書いたようにリポジトリをチェックアウトしておいてください。そうすると指定したアドレスから受信したメールの添付ファイルを適切な位置に保存してSVNにコミットしてれます。ZIPファイルの場合はファイルを展開して一階層のフォルダを捨てたうえで展開してコミットします。

いろいろエラー処理とか追加したほうがよいとも思うんですが、私自身が必要としている範囲を大きく超える必要もないかということで、こんなかんじかなぁ。本業がメールにおぼれてえらいことになったので作っただけなので、本業のほうがかたづけばそれでいいということで、必要な人がいなければ、ここまででいいのかなってことでお許しを…

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Option Explicit

Public Keys As Collection
Public Values As Collection

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

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

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

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

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

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

Option Explicit

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

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

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

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

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

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

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

Option Explicit

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

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

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

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

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

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

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

Option Explicit

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

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

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

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

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

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

Option Explicit

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

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

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

Dim m_field As Map

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

フォームのコードは

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

2,名前から選択する

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

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

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

フォームの処理は

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

Public RetCode As Integer

Private Sub BCancel_Click()
    Unload Me
End Sub

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

Private Sub UserForm_Initialize()
    RetCode = vbCancel
End Sub

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

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

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

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

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

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

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

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

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

設定シート

ワークフローシート

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

使い方の手順は

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

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

 

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

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

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

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

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

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

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

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

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

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

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

ThisWorkBookのマクロ

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

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

Module1のマクロ

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Trac-Outlook連携を使った朝会の準備

Shibuya.trac 第8回勉強会で朝回はwikiに書くということを聞いた．そういえばうちも似たようなことやってるなぁって事でその元になったものを公開します．職場向けのものはだいぶ更新して使っていて，これはあまり試してないのでバグがあるかもしれません．このマクロは，前に公開したTrac-Outlook連携のマクロと組み合わせることで，outlookに取り込んだTracのチケットと，会議やその他の予定とかその他のちょっとした作業をまとめてメールの元を作るものです．

出力結果は

本文を抜き出すと

各位

1.本日の作業予定

2. オープンの仕事

・              Test1:#2  test1-1

！  10/04-10/08 Test1:#8  10/04-10/08 期限切れのチケット

※ 凡例: ！=期間を過ぎている＊=今日作業予定

3.今後(一ヶ月)のスケジュール

10/11(Mon)             体育の日

10/13(Wed) 10:00-12:00 打ち合わせ

10/14(Thu)-10/15(Fri)  出張

4. 完了した作業

4.1. TracPlugin:#6  09/27-10/15 outlook connectorを登録する

4.2. Test1:#9  10/08-10/11 完了したチケット

5. 完了した作業の詳細

5.1. TracPlugin:#6  09/27-10/15 outlook connectorを登録する

http://192.168.0.65/trac/TracPlugin/ticket/6

Do not edit this task item.

n. 自動で登録するVBSを作る

n. ゴミ削除

========

5.2. Test1:#9  10/08-10/11 完了したチケット

http://192.168.1.4/trac/Test1/ticket/9

Do not edit this task item.

ここ(description)に作業内容とか書いておけばこのメールに作業内容が入ります．

========

以上，

本文の番号のところには次のような情報を書いたり，マクロによって書かれています．

1. 今日の作業を優先順位を決めて自分で書くか2の所からコピーしてくる
2. オープン状態のタスクの一覧Tracから取り込んでいればそれも表示される．通常は＊が付いているものが本日の作業．！が付いているものは期日を過ぎている
3. 今後一カ月の予定が表示されます
4. このメールを前回送信した時間から今までの間に完了したものを表示
5. 上のものの中で仕事の本文に何か書いてあるものはそれを表示する．Tracのチケットなら説明のところ

次はソースです．いつものようにどこかの標準モジュールに張り付けて，適当にツールバーのボタンに”今日の予定”を結び付けてください．

Function 予定の表示文字列を作成(app As AppointmentItem) As String
    予定の表示文字列を作成 = month(app.Start) & "/" & Day(app.Start) & " " & Hour(app.Start) & ":" & Minute(app.Start)
    If app.AllDayEvent Then
        If app.End - app.Start > 1# Then
            予定の表示文字列を作成 = Format(app.Start, "MM/DD(ddd)-") & Format(app.End - 1# / 24 / 3600, "MM/DD(ddd)  ") & app.Subject
        Else
            予定の表示文字列を作成 = Format(app.Start, "MM/DD(ddd)             ") & app.Subject
        End If
    Else
        If app.End - app.Start > 1# Then
            予定の表示文字列を作成 = Format(app.Start, "MM/DD(ddd)-") & Format(app.End, "MM/DD       ") & app.Subject
        Else
            予定の表示文字列を作成 = Format(app.Start, "MM/DD(ddd) hh:mm-") & Format(app.End, "hh:mm ") & app.Subject
        End If
    End If
    If app.Location <> "" Then
        予定の表示文字列を作成 = 予定の表示文字列を作成 & "(" & app.Location & ")"
    End If
   
End Function

Sub 今日の予定()
    Dim mailbody As String
    Dim tItem As TaskItem
    Const mailSubject As String = "【連絡】本日の作業予定"
   
    Set objNamespace = Application.GetNamespace("MAPI")
   
    Set objFolder = objNamespace.GetDefaultFolder(olFolderTasks)
    Set colTasks = objFolder.Items

    mailbody = "各位" & vbCrLf & vbCrLf & "1.本日の作業予定" & vbCrLf & vbCrLf & _
    "2. オープンの仕事" & vbCrLf

    For Each objTask In colTasks
        Set tItem = objTask
        'If objTask.PercentComplete < 100 And InStr(1, objTask.Subject, "????:#") <> 1 Then
        If objTask.PercentComplete < 100 Then
            If tItem.StartDate < Now() Then '開始日が今日より前
                If tItem.DueDate < Now() + 1 Then '期間切れかどうか
                    mailbody = mailbody + "！ "
                Else
                    mailbody = mailbody + "＊ "
                End If
            Else
                mailbody = mailbody + "・ "
            End If
            If tItem.StartDate = #1/1/4501# Then '期間が設定されているか
                mailbody = mailbody + "             "
            Else
                mailbody = mailbody + " " + Format(tItem.StartDate, "MM/DD-") + Format(tItem.DueDate, "MM/DD ")
            End If
            mailbody = mailbody + objTask.Subject & vbCrLf
        End If
    Next
    mailbody = mailbody + "※ 凡例: ！=期間を過ぎている ＊=今日作業予定" & vbCrLf
    Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
    Dim colApps As Items
    Set colApps = objFolder.Items
    mailbody = mailbody + vbCrLf & "3.今後(一ヶ月)のスケジュール" & vbCrLf
    Dim app As AppointmentItem
    colApps.sort ("Start")
    For Each objApp In colApps
        Set app = objApp
        If (app.Start > Int(Now()) And app.Start < Int(Now()) + 31) _
           Or (app.End > Int(Now()) And app.End < Int(Now()) + 31) Then
            mailbody = mailbody + 予定の表示文字列を作成(app) & vbCrLf
        End If 'Exit do入れたほうがいいかもしれないがそのまま
    Next
    Set myFolder = objNamespace.GetDefaultFolder(olFolderSentMail)
    Set colSentItems = myFolder.Items
    Debug.Print colSentItems.Count
    colSentItems.sort "SentOn"
    '　前に送ったメールを検索し，prevDateにその時刻を設定する．
    ' 送信済みのアイテムを検索しますので，仕分けしている場合は修正してください．
    Dim prevDate As Date
    prevDate = Now() - 30 '見つからなかったら30日前にしておく
    For Num = colSentItems.Count To 1 Step -1
        Set item1 = colSentItems(Num)
        If item1.Subject = mailSubject Then
            prevDate = item1.SentOn
            Exit For
        End If
    Next
    Debug.Print Format(prevDate, "YYYY/MM/DD-") & Format(Now(), "YYYY/MM/DD")
    mailbody = mailbody + vbCrLf & "4. 完了した作業" & vbCrLf
    closedTasks = ""
    closedDescription = ""
    Dim no As Integer '番号は一致させたほうがいいと思うので一つの変数にする
    no = 1
    For Each objTask In colTasks
        If objTask.PercentComplete = 100 And prevDate <= objTask.DateCompleted And objTask.DateCompleted < Now() Then
            closedTasks = closedTasks + "4." & no & ". " & objTask.Subject & vbCrLf
            If objTask.body <> "" Then
                closedDescription = closedDescription + "5." & no & ". " & objTask.Subject & vbCrLf
                closedDescription = closedDescription + objTask.body & vbCrLf & vbCrLf
                closedDescription = closedDescription + "========" & vbCrLf
            End If
            no = no + 1
        End If
    Next
    mailbody = mailbody + closedTasks & vbCrLf & vbCrLf
    mailbody = mailbody + vbCrLf & "5. 完了した作業の詳細" & vbCrLf
    mailbody = mailbody + closedDescription & vbCrLf

    mailbody = mailbody + vbCrLf & "以上，" & vbCrLf
    mailbody = mailbody + vbCrLf & "" & vbCrLf ' 自分の名前を書く
   
    Dim objMail As MailItem
    Set objMail = Application.CreateItem(olMailItem) 'olMailItem=0
    objMail.To = Application.Session.CurrentUser.Address ' 送信したいアドレスに変更してください
    objMail.Subject = mailSubject
    objMail.body = mailbody
    objMail.Display
End Sub

昨日やったことはどうするかですが，いろいろやり方があるところなので，まだ実装してません．

取り込んだTracのチケットをWebページを開くコンテキストメニューを追加する

勢いのあるうちに書いていかないとまた更新しなくなっちゃいそうなので，Outlookのタスクのなかで，内容の先頭行に"HTTP://"があった場合に，そのページを開くコンテキストメニューを追加する方法について書きます．CRがあることを前提としているので内容が二行以上ないとだめです．これがあれば，チケットを更新するときも少し楽になるかなぁ

まずは，ThisOutlookSessionにコンテキストメニューが表示されるときに呼ばれる，Application_ItemContextMenuDisplayを追加します．

Private Sub Application_ItemContextMenuDisplay(ByVal CommandBar As Office.CommandBar, ByVal Selection As Selection)
    If Selection.Count = 1 And Selection.Item(1).Class = olTask Then
        Dim tItem As TaskItem
        Set tItem = Selection.Item(1)
        Debug.Print tItem.Subject
        If InStr(1, tItem.Body, "http://") = 1 Then
            Dim btn As CommandBarButton
            Set btn = CommandBar.Controls.Add(msoControlButton, Temporary:=True)
            btn.Caption = "リンクを開く"
            btn.OnAction = "リンクを開く"
        End If
    End If
End Sub

次にOnActionに設定している"リンクを開く"をどこかの標準モジュールに追加します．

Sub リンクを開く()
    Dim sel As Selection
    Set sel = Application.ActiveExplorer.Selection
    If sel.Item(1).Class = olTask Then
        Dim tItem As TaskItem
        Set tItem = sel.Item(1)
        Debug.Print tItem.Subject
        If InStr(1, tItem.Body, "http://") = 1 Then
            'http://officetanaka.net/excel/vba/tips/tips42.htm
            Dim WSH
            Set WSH = CreateObject("Wscript.Shell")
            WSH.Run Left(tItem.Body, InStr(7, tItem.Body, "" & vbCr)), 3
            Set WSH = Nothing
        End If
    End If
End Sub

Outlookへマクロを追加する方法とツールバーの編集

  せっかくなので前の記事のマクロをOutlookへ追加してツールバーを編集してみましょう．

1. マクロを使用できるようにする

ツール-セキュリティセンターでマクロのセキュリティを選択しレベルを適切に設定して再起動してください．

2. VBEditorを起動

ALT+F11でVisualBasicEditorを起動します．

3. ファイルをインポートします

ファイル-ファイルのインポート(CTRL+M)で次の3ファイルをインポートします．

              Trac.bas

              TracOutlookConnector.cls

              TracXMLRPC.cls

4. 実行する環境に合わせ内容を変更します．

標準モジュールのTracをダブルクリックし，ファイルを開きます．ユーザ名やアドレスなどを適切に設定し,何もしないと完了がわからないので，メッセージボックスを追加して，まず保存(CTRL+S)し，マクロを実行(F5)します．

5. ツールバーを追加

表示-ツールバー-ユーザー設定でツールバータブの新規作成ボタンを押す

適当にツールバーの名前を入力します．

6. ボタンを追加

コマンドタブに切り替え，分類でマクロを選択し，表示されたマクロをさっき追加したツールバーにドロップします．

7. ボタンと名前を変更します．

コマンドの配置の変更ボタンを押します．

先ほどのツールバーを選び，追加したボタンを選択し，選択したボタンの編集ボタンを押します．

あとは適当に変更すると

こうなります．

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

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

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

後はソースです．次のものは標準モジュールのどこかに追加してください．これは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
                '日付でも値が入ってない場合はここに入ってこないうえに値に０が入ってる
                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 '終了日が入っていない場合はなぜか０がくる
        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 '終了日が入っていない場合はなぜか０がくる
        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が正常に設定できない問題がありましたので修正したものを再アップしました．

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

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

バーンダウンチャート

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

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

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

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

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

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

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

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

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

    createBurndown trac, Sheet2, 3, 31
   
End Sub

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

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

参照

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