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 StringPrivate Sub Class_Initialize()
End SubPublic 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 FunctionSub 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&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 StringDim 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 BooleanDim 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 FunctionPrivate Function getStruct_sub(method As String, params As String) As Collection
Dim d As Collection
Set Members = getMember(method, params, "member")
If Members Is Nothing Or Members.Length = 0 Then '何も戻ってこなかったら
Set getStruct_sub = Nothing
Exit Function
End If
Set d = New Collection
Dim n As String, v As String
For i = 0 To Members.Length - 1
Set oNodeList = Members.Item(i).ChildNodes
If oNodeList.Length = 2 Then
n = oNodeList(0).text '名
v = oNodeList(1).text '値
nn = oNodeList(1).ChildNodes(0).nodeName 'ノード名
If nn = "dateTime.iso8601" Then
'日付でも値が入ってない場合はここに入ってこないうえに値に0が入ってる
v = convertDateStr(v) '日付を修正
End If
d.Add v, n 'コレクションに値を追加
' Debug.Print " " & n & "=" & v
End If
yield
Next
Set getStruct_sub = d
End Function'TODO:publiv->privateに変更したが問題無いか確認
Private Function getStruct(method As String, name As String, dataType As String) As Collection
Dim params As String
params = "<param><value><" & dataType & ">" & name & "</" & dataType & "></value></param>"
Set getStruct = getStruct_sub(method, params)
End Function'milestone等の情報を取得します.指定できるのは次のものです.
'"resolution","milestone","version","component","priority","severity"
Private Sub getStructArray(ByRef d As Collection, typeName As String)
getStructArray_Sub d, typeName, "ticket." & typeName & ".getAll", ""
End SubPrivate 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 SubPrivate 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 FunctionPublic 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 FunctionPublic Function updateTicket(id As Long, comment As String, attributes As Collection, notify As Boolean) As Collection
'array ticket.update(int id, string comment, struct attributes={}, boolean notify=False)
'Update a ticket, returning the new ticket in the same form as getTicket().
Dim funcName As String, params As String, dataType As String
funcName = "ticket.update"
params = _
"<param><value><i4>" & id & "</i4></value></param>" & vbCrLf & _
"<param><value><string>" & comment & "</string></value></param>" & vbCrLf & _
"<param><value>" & vbCrLf & _
createStruct(attributes) & vbCrLf & _
"</value></param>" & vbCrLf & _
"<param><value><boolean>" & CStr(Abs(CInt(notify))) & "</boolean></value></param>"
' Debug.Print params
Set updateTicket = getStruct_sub(funcName, params)
End Function'チケット(Collection)のCollectionを返します.
'第二引数を削除した.
'Public Function queryTicket(query As String, enableTree As Boolean) As Collection
Public Function queryTicket(query As String) As Collection
Dim funcName As String, queryString As String, dataType As String
funcName = "ticket.query"
dataType = "int"
Set queryTicket = New Collection
Dim ticketId As String
ticketId = "0"
Do
If query = "" Then
queryString = ""
Else
queryString = "<param>" & query & "</param>"
End If
Set Members = getMember(funcName, queryString, dataType)
For i = 0 To Members.Length - 1
Set oNodeList = Members.Item(i).ChildNodes
ticketId = oNodeList(0).text
Set ti = getTicket(ticketId)
queryTicket.Add ti, ticketId
yield
Next
Exit Do
Loop
End Function'Tracに接続してレスポンスを得て,指定したタグの一覧を返します.
Private Function getMember(method As String, params As String, tag As String) As Variant
' Dim xmlSv As MSXML2.xmlHttp
' Set xmlSv = New MSXML2.xmlHttp
'参照設定が無くても使えるようにする
Dim xmlSv As Variant
Set xmlSv = CreateObject("MSXML2.XMLHTTP")
Dim addr As String
addr = Me.URL() & "/login/xmlrpc"
xmlSv.Open "POST", addr, False, m_user, m_pw
xmlSv.setRequestHeader "Method", "POST " & addr & " HTTP/1.1"
xmlSv.setRequestHeader "Content-Type", "text/xml"
On Error GoTo conerr
If method <> "" Then
param = "<?xml version='1.0' encoding='utf-8'?>" & vbNewLine & _
"<methodCall>" & _
" <methodName>" & method & "</methodName>" & _
" <params>" & params & "</params>" & _
"</methodCall>"
Call xmlSv.send(param)
'"fault"
End If
On Error GoTo 0
If checkError(xmlSv) = False Then
Set getMember = Nothing
Exit Function
End If
Set getMember = xmlSv.responseXML.getElementsByTagName(tag)
Exit Function
conerr:
err.Raise vbObjectError + 516, , "Con not connect server"
End Function'Responseがエラーかどうかを判断します。
'TODO:確認
Private Function checkError(xmlSv As Variant) As Boolean
checkError = False
Set Members = xmlSv.responseXML.getElementsByTagName("fault")
Dim errorMessage As String
errorMessage = ""
checkError = False
If xmlSv.status <= 100 Or xmlSv.status > 200 Then
'認証に失敗したとかHTTPにアクセスするときまでの問題の処理
err.Raise vbObjectError + 513, , "Error:" & _
xmlSv.statusText & "(" & xmlSv.status & ")"
ElseIf Members.Length = 0 Then
'faultが無かった場合はちゃんとXMLでレスポンスがあったか確認します.
If xmlSv.responseXML.getElementsByTagName("methodResponse").Length > 0 Then
checkError = True
Exit Function
End If
err.Raise vbObjectError + 514, , "Not an XML response."
Else
'faultがあった場合エラーメッセージをまとめます
Set Members = xmlSv.responseXML.getElementsByTagName("member")
For i = 0 To Members.Length - 1
Set oNodeList = Members.Item(i).ChildNodes
If oNodeList.Item(0).text = "faultCode" Then
errorMessage = errorMessage & "Code=" & oNodeList.Item(1).text
End If
If oNodeList.Item(0).text = "faultString" Then
errorMessage = errorMessage & ":" & oNodeList.Item(1).text
End If
yield
Next
End If
If errorMessage <> "" Then
' MsgBox errorMessage
err.Raise vbObjectError + 515, , errorMessage
End If
End Function'時間を文字列の時間に変換します
'TODO:時差は9時間を固定で入れているのでシステムの設定からとる
Private Function convertDateStr(text As String) As String
'20090317T16:10:12 なので+9Hしないとだめ
Dim d As Date
If text = "0" Then '終了日が入っていない場合はなぜか0がくる
convertDateStr = ""
Exit Function
End If
If Len(text) <> 17 Then
'正規表現を使うのはめんどくさいので長さだけを見る
convertDateStr = ""
err.Raise vbObjectError + 515, , "Error: Date format is wrong (" & text & "). Check the XMLRPC responses."
Exit Function
End If
d = DateSerial(Mid$(text, 1, 4), Mid$(text, 5, 2), Mid$(text, 7, 2))
d = DateAdd("h", Int(Mid$(text, 10, 2)), d)
d = DateAdd("n", Int(Mid$(text, 13, 2)), d)
d = DateAdd("s", Int(Mid$(text, 16, 2)), d)
d = DateAdd("h", m_timeDifference, d)
convertDateStr = Format(d, "yyyy/mm/dd h:m:s")
End Function'時間を文字列の時間に変換します
'TODO:時差は9時間を固定で入れているのでシステムの設定からとる
Private Function convertDate(text As String) As Date
'20090317T16:10:12 なので+9Hしないとだめ
Dim d As Date
If text = "0" Then '終了日が入っていない場合はなぜか0がくる
convertDate = ""
Exit Function
End If
If Len(text) <> 17 Then
'正規表現を使うのはめんどくさいので長さだけを見る
convertDate = ""
err.Raise vbObjectError + 515, , "Error: Date format is wrong (" & text & "). Check the XMLRPC responses."
Exit Function
End If
d = DateSerial(Mid$(text, 1, 4), Mid$(text, 5, 2), Mid$(text, 7, 2))
d = DateAdd("h", Int(Mid$(text, 10, 2)), d)
d = DateAdd("n", Int(Mid$(text, 13, 2)), d)
d = DateAdd("s", Int(Mid$(text, 16, 2)), d)
d = DateAdd("h", m_timeDifference, d)
convertDate = d
End FunctionPublic 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 PropertyPublic 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 PropertyPublic Property Get ticketType() As Collection
If m_type Is Nothing Then
getStringArray m_type, "type"
End If
Set ticketType = m_type
End PropertyPublic Property Get status() As Collection
If m_status Is Nothing Then
getStringArray m_status, "status"
End If
Set status = m_status
End PropertyPublic Property Get component() As Collection
If m_component Is Nothing Then
getStructArray m_component, "component"
End If
Set component = m_component
End PropertyPublic Property Get priority() As Collection
If m_priority Is Nothing Then
getStringArray m_priority, "priority"
End If
Set priority = m_priority
End PropertyPublic Property Get resolution() As Collection
If m_resolution Is Nothing Then
getStructArray m_resolution, "resolution"
End If
Set resolution = m_resolution
End PropertyPublic Property Get severity() As Collection
If m_severity Is Nothing Then
getStringArray m_severity, "severity"
End If
Set severity = m_severity
End PropertyPublic 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 PropertyPublic Property Get URL() As String
URL = m_URL
End Property
Public Property Get projectName() As String
projectName = m_projectName
End PropertyPublic Property Get initialized() As Boolean
initialized = m_initialized
End PropertyPrivate Sub yield()
DoEvents
End SubPublic 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 FunctionPublic 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPublic 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 FunctionPublic 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 FunctionPublic 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」カテゴリの記事
- Dockerでkanon(Trac)を動かしてみた2 - イメージの作成(2017.08.27)
- Dockerでkanon(Trac)を動かしてみた(2017.08.27)
- TracLightningにコバンザメしてKanonと同様にPluginをインストールする(2014.04.13)
- kanonをTrac1.0.1+MySQL対応に変更してみた(2013.11.24)
- kanonをTrac1.0.1対応に変更してみた(2013.11.11)
「VBA」カテゴリの記事
- メールで受け取ったファイルをSVNに登録する(2012.01.22)
- VBAでXMLRPCを汎用的に修正してTrac連携をそれに合わせて修正した(2011.10.24)
- Excelの(名前の管理のところの)名前の範囲の編集と,名前の範囲の値から複数選択するフォームとマクロ(2011.06.12)
- 状態遷移図からTracのワークフローを作るマクロにTracの設定の取り込み機能追加(2011.02.28)
- tracのワークフローをExcelの図で作った状態遷移図から作ってみる(2011.02.06)
「XMLRPC」カテゴリの記事
- TracのXMLRPCを使ったExcelのマクロでmilestoneなどの設定を取得/更新する(2011.10.31)
- VBAでXMLRPCを汎用的に修正してTrac連携をそれに合わせて修正した(2011.10.24)
- TracのチケットをOutlookに取り込んで表示する.(2010.02.12)
- ユーザ名を漢字で表示するために,Tracユーザの一覧をXMLRPCで取得する(2009.10.18)
- TracのデータからバーンダウンチャートをExcelで作る(2009.10.13)
「MS-Outlook」カテゴリの記事
- メールで受け取ったファイルをSVNに登録する(2012.01.22)
- Trac-Outlook連携を使った朝会の準備(2010.10.11)
- 取り込んだTracのチケットをWebページを開くコンテキストメニューを追加する(2010.02.15)
- Outlookへマクロを追加する方法とツールバーの編集(2010.02.13)
- TracのチケットをOutlookに取り込んで表示する.(2010.02.12)
この記事へのコメントは終了しました。
コメント
チケット取得数の上限はtrac.iniのquery → items_per_page で変更できるようです。
投稿: かおるん | 2010年2月13日 (土) 01時12分
かおるんさんありがとうございます.そうですね,変更できましたね.自分で調べて書いたことも忘れていました.(/ω\) 修正しておきます
投稿: u-z | 2010年2月13日 (土) 08時30分
これまでTracLightning3.1.3で快適にチケット管理してきたのですが、
先ごろ全社的にoutlook予定表を強要される状況となりまして、なんと
か連携方法を探っている者です。
ガントチャートがないのでoutlookだけでは困っちゃう。。
このページを拝見させて頂き、非常に有益な情報開示がされている
ことは読み取れ、すっごく喜んだのですが、いかんせんTracLightning
の中身がよくわからず、開示頂けてるソースの適用方法が検討つきま
せん。
TracLightingを利用している初心者でも可能な導入方法を教えて頂け
ないでしょうか?
大変な事をお願いしちゃってるんだと思います。
後生です!
投稿: yasoo7964 | 2013年10月11日 (金) 11時55分
yasoo7964さん
outlook予定表で管理とありますが、予定表のアイテムのことでしょうか。それともタスクのこと?予定表のほうだとしても、マクロを修正すれば登録することはできると思いますが、このマクロはタスクとして取り込みます。ソースはOutlookのVBAになっていますので、OutlookのVBAの編集方法がわかれば使用できるはずです。TracLightningでは標準でOnになっていると思いますが、XML-RPCを使用して接続していますので、基本的にはTrac側で何かする必要はありません。とはいっても、挫折されている人も多いようなので、いつかまとめなおしておきます。
投稿: u-z | 2013年10月13日 (日) 10時38分