TracのチケットをMS-Projectのタスクへ変換しガントチャート/カレンダーを表示

VBAそのものがよくわからないんで、何かご指摘があればコメントお願いします。次のリストは、プロジェクトファイルを開いたときに自動で、今あるものを削除してTracのチケットをコピーしてくるマクロです。ADOを使えるようにするのとセキュリティレベル等は適切に変更してください。

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

Function getConnectionString() As String
    getConnectionString = "Driver=SQLite3 ODBC Driver; Database=D:\TracLight\projects\trac\tracplugin\db\trac.db"
End Function

Function getSqlString(id As Long) As String
' チケットを抽出するためのSQLを作ります
    Dim Sql As String
    Sql = "SELECT t.id, "
    Sql = Sql + " t.summary as '概要', "
    Sql = Sql + " t.owner as '担当', "
    Sql = Sql + " a.value as '開始(予)', "
    Sql = Sql + " c.value as '終了(予)', "
    Sql = Sql + " d.value as '進捗率', "
    Sql = Sql + " g.value as '開始(計画)', "
    Sql = Sql + " h.value as '終了(計画)', "
    Sql = Sql + " i.value as '親', "
'    Sql = Sql + "t.type AS 'タイプ', "
'    Sql = Sql + "f.value as '終了', "
'    Sql = Sql + "t.milestone as 'マイルストーン', "
'    Sql = Sql + "t.version as 'バージョン', "
    Sql = Sql + " e.value as '状況' "
    Sql = Sql + " from ticket t "
    Sql = Sql + " LEFT JOIN ticket_custom a ON a.ticket = t.id AND a.name = 'due_assign' "
    Sql = Sql + " LEFT JOIN ticket_custom c ON c.ticket = t.id AND c.name = 'due_close' "
    Sql = Sql + " LEFT JOIN ticket_custom d ON d.ticket = t.id AND d.name = 'complete'"
    Sql = Sql + " LEFT JOIN ticket_custom e ON e.ticket = t.id AND e.name = 'condition' "
    Sql = Sql + " LEFT JOIN ticket_custom f ON f.ticket = t.id AND f.name = 'close' "
    Sql = Sql + " LEFT JOIN ticket_custom g ON g.ticket = t.id AND g.name = 'plan_start' "
    Sql = Sql + " LEFT JOIN ticket_custom h ON h.ticket = t.id AND h.name = 'plan_end' "
    Sql = Sql + " LEFT JOIN ticket_custom i ON i.ticket = t.id AND i.name = 'parent' "
    If id > 0 Then
        Sql = Sql + " where i.value ='" & id & "'"
    Else
        'カスタムフィールドはチケットの更新をしただけでレコードは追加されてしまう
        Sql = Sql + " where (i.value Is Null or i.value ='')"
    End If
    getSqlString = Sql
End Function

Sub setTask(level As Long, rs As ADODB.Recordset, cn As ADODB.Connection)
    Dim count As Integer
    Dim val As Variant
    Dim plan As Integer
    Dim due As Integer
    plan = 0
    due = 0
    'タスク名を設定
    Application.ActiveProject.Tasks.Add Name:=rs.Fields(1).Value
    'すべてのタスク数を得る
    count = Application.ActiveProject.Tasks.count
    '何かと面倒なので期間固定とする
    Application.ActiveProject.Tasks(count).Type = pjFixedDuration
    ' どうでもいいけどハイパーリンクを設定しておく
    Application.ActiveProject.Tasks(count).HyperlinkHREF = "http://localhost/trac/tracplugin/ticket/" & rs!id
    Application.ActiveProject.Tasks(count).Hyperlink = "#" & rs!id
    ' ?がつくので'期間のを見積もりでなくする
    Application.ActiveProject.Tasks(count).Estimated = False
'==============================================
    '基準計画の開始日を設定
    val = rs.Fields(6).Value
    If Not IsNull(val) Then
        Application.ActiveProject.Tasks(count).BaselineStart = val
        plan = plan + 1
    End If
    '基準計画の終了日を設定
    val = rs.Fields(7).Value
    If Not IsNull(val) Then
        Application.ActiveProject.Tasks(count).BaselineFinish = val
        plan = plan + 1
    End If
   
    '開始日を設定
    val = rs.Fields(3).Value
    If Not IsNull(val) Then
        Application.ActiveProject.Tasks(count).Start = val
        due = due + 1
    End If
    '終了日を設定
    val = rs.Fields(4).Value
    If Not IsNull(val) Then
        Application.ActiveProject.Tasks(count).Finish = val
        due = due + 1
    End If
    'リソース名を設定、Tracは基本一人なので一人になる
    val = rs.Fields(2).Value
    If Not IsNull(val) Then
        Application.ActiveProject.Tasks(count).ResourceNames = val
    End If
    val = rs.Fields(5).Value
    '進捗率を入力
    If Not IsNull(val) Then
        Application.ActiveProject.Tasks(count).PercentComplete = val
    End If
'   アウトラインレベルを調整する
    olev = Application.ActiveProject.Tasks(count).OutlineLevel
    If olev > level Then
        For i = 1 To olev - level
            Call Application.ActiveProject.Tasks(count).OutlineOutdent
        Next
    ElseIf olev < level Then
        For i = 1 To level - olev
            Call Application.ActiveProject.Tasks(count).OutlineIndent
        Next
    End If
'   子タスクを追加する
    ii = copySubTask(rs!id, level, cn)
End Sub

Function copySubTask(ticket As Long, level As Long, cn As ADODB.Connection) As Integer
    Dim rs As New ADODB.Recordset
    Dim ticketCount As Integer
    ticketCount = 0
    rs.Open getSqlString(ticket), cn
    Do Until rs.EOF = True
        Call setTask(level + 1, rs, cn)
        rs.MoveNext
        ticketCount = ticketCount + 1
    Loop
    copySubTask = ticketCount
End Function

Sub copyTopLevelTask(level As Long, cn As ADODB.Connection)
    Call copySubTask(0, 0, cn)
End Sub

Sub copyTicketFromTrac()
    Dim cn As New ADODB.Connection
    cn.Open getConnectionString()
    Call copyTopLevelTask(0, cn)
End Sub

Private Sub Project_Open(ByVal pj As Project)
    Do Until Application.ActiveProject.Tasks.count = 0
        Application.ActiveProject.Tasks(1).Delete
    Loop
    Call copyTicketFromTrac
End Sub

使っているカスタムフィールドは次の絵の下線を引いてあるものです。

あとはマイルストーンをどう扱うかってとこと、サマリータスクに日付が入っていた時や、葉タスクに日付が入っていないときのエラー処理ですかね。