t-hom’s diary

主にVBAネタを扱っているブログ…とも言えなくなってきたこの頃。

PowerPoint VBA スライドにプロジェクトのスケジュール図をプロットするマクロ

今回はパワポでよくあるこういうスケジュールスライドを作るVBAコードを紹介。
f:id:t-hom:20190319224303p:plain

と言っても現段階では完成度は低いのであまり期待されると困ってしまう。

ところどころハードコーディングしているし、クラスモジュール内でSelectionを参照しちゃってるし、変数名がまだまだ適当なところあるし変数宣言もしてたりしてなかったりだしといった具合。
使い勝手という意味でも、スケジュールはコードにベタ打ちだし、微調整が効かずイマイチ。

でも良いアイデアだと思うので、使えそうなら部品取りして改造するなりこれをヒントにイケてるツールを作るなりしてもらえれば幸い。私は私で、ブラッシュアップしてみようと思う。

コード

書き殴りでもクラスモジュールは使う。むしろオートシェイプ系は座標計算が入ってくるのでクラスを使って操作性をシンプルに保たないと頭がこんがらがる。

クラスモジュール Task

Public StartDay As Date
Public EndDay As Date
Public Title As String
Public Property Get Self() As Object
    Set Self = Me
End Property

クラスモジュール Schedule

Private schedule_ As Collection
Public Width As Double
Public Height As Double
Public StartDay As Date
Public EndDay As Date
Property Get MonthCount() As Long
    MonthCount = DateDiff("m", StartDay, EndDay) + 1
End Property
Property Get MonthlyWidth() As Double
    MonthlyWidth = Width / MonthCount
End Property

Function CalcDateLocation(d As Date) As Double
    Dim ret As Double
    ret = DateDiff("m", StartDay, d) * MonthlyWidth
    ret = ret + (MonthlyWidth * CalcRatioOfDateInMonth(d))
    CalcDateLocation = ret
End Function

Sub Add(t As Task)
    schedule_.Add t
End Sub

Private Sub Class_Initialize()
    Set schedule_ = New Collection
End Sub

Private Function CalcRatioOfDateInMonth(d As Date)
    CalcRatioOfDateInMonth = Day(d) / Day(CalcEndOfMonth(d))
End Function
Private Function CalcEndOfMonth(d As Date)
  CalcEndOfMonth = DateSerial(Year(d), Month(d) + 1, 0)
End Function

Public Sub Plot()
    OFFSET_L = 50
    OFFSET_T = 50
    Margin = 50
    Dim calender As Table
    Set calender = ActiveWindow.Selection.SlideRange.Shapes.AddTable(NumRows:=2, NumColumns:=MonthCount, Left:=OFFSET_L, Top:=OFFSET_T, Width:=Width).Table
    calender.ApplyStyle "{5940675A-B579-460E-94D1-54222C63F5DA}"
    
    Dim m As Long: m = Month(StartDay)
    calender.Rows(2).Height = Height
    For i = 1 To MonthCount
        calender.Cell(1, i).Shape.TextFrame.TextRange.Text = Format(DateSerial(2019, m, 1), "mmm")
        m = m + 1
    Next
    
    Dim t As Task
    
    Dim targetSlide As Slide
    Set targetSlide = ActiveWindow.Selection.SlideRange(1)
    
    start_y = OFFSET_T + calender.Rows(1).Height + Margin / 2
    arrowWeight = calender.Rows(2).Height / schedule_.Count - Margin
    
    For Each t In schedule_
        L = CalcDateLocation(t.StartDay)
        W = CalcDateLocation(t.EndDay) - CalcDateLocation(t.StartDay)
        start_x = L + OFFSET_L
        arrowLength = W
        targetSlide.Shapes.AddShape(msoShapePentagon, start_x, start_y, arrowLength, arrowWeight).Select
        start_y = start_y + arrowWeight + Margin
    Next
End Sub

標準モジュール (任意名称)

Sub スケジュールのプロット()
    Dim s As Schedule
    Set s = New Schedule
    s.Width = ActivePresentation.PageSetup.SlideWidth * 0.8
    s.Height = ActivePresentation.PageSetup.SlideHeight * 0.8
    s.StartDay = Now
    s.EndDay = #7/10/2019#
    With New Task
        .StartDay = Now
        .EndDay = #3/31/2019#
        s.Add .Self
    End With
    With New Task
        .StartDay = #4/5/2019#
        .EndDay = #5/15/2019#
        s.Add .Self
    End With
    With New Task
        .StartDay = #5/17/2019#
        .EndDay = #6/20/2019#
        s.Add .Self
    End With
    With New Task
        .StartDay = #6/22/2019#
        .EndDay = #7/20/2019#
        s.Add .Self
    End With
    s.Plot
End Sub

使い方

白紙のスライドを選択し、スケジュールのプロットを実行するとコード内で定義されたタスクがスライドにプロットされる。

ScheduleオブジェクトのStartDayとEndDayは、背景に配置する表を何月から何月とするかを決定している。

たとえば2019/1/1から2019/12/1まで指定すると12分割される。
f:id:t-hom:20190319225721p:plain

タスクを表すシェイプの高さはタスクの数によって変動する。均等割りされるのでタスクが1個とか2個だとすごく太いシェイプになる。

今後の展望

  • フォームモジュールでタスク登録のUIを作る。
  • コードのリファクタリング
  • サイズの指定を比率と固定値で選択できるように
  • タスクの名称をシェイプに入れる(Titleフィールドだけ用意して放置中)

以上

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。