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