PowerPointでExcelセルの値を座標とした折れ線を描画したい

メモ

PowerPointのスライドにAddPolylineでフリーフォームを描画する。
フリーフォームにおける頂点の座標は、GetObjectとRangeSelectionで起動中のExcelから取得する。

参考資料リンク

• GetObject function (Visual Basic for Applications) | Microsoft Docs
• Shapes.AddPolyline method (PowerPoint) | Microsoft Docs
• Control One Microsoft Office Application from Another | Microsoft Docs
• Controlling One Microsoft Office Application from Another | Microsoft Docs

使い捨てマクロ

' PowerPoint 2013
' Alt + F11 → 挿入(I) → 標準モジュール(M)

' 参照設定
' ツール(T) → 参照設定(R)
' Microsoft Excel 16.0 Object Library
' "C:\Program Files\Microsoft Office\root\Office16\EXCEL.EXE"

' 既に1つだけ起動してあるExcelにおける
' セル選択範囲(N行2列, 1列目はX座標[mm], 2列目はY座標[mm])の値を、
' PowerPointのスライドに折れ線として描画する。
' スライドでの原点(X=0mm, Y=0mm)はスライド左下とし、
' 右方向にX軸を正、上方向にY軸を正とする。

Option Explicit

Private Function MillimetersToPoints(ByVal millimeters As Single) As Single
  ' 1[pt] = 1[in] / 72 = (25.4/72)[mm]
  ' 1[-]  = (72/25.4)[pt/mm]
  MillimetersToPoints = millimeters * 72 / 25.4
End Function

Public Sub Main()
  Dim pptDocWnd As PowerPoint.DocumentWindow
  Dim pptSldRng As PowerPoint.SlideRange
  Dim pptPr As PowerPoint.Presentation
  Dim pptSld As PowerPoint.Slide
  Dim pptShps As PowerPoint.Shapes
  Dim pptShp As PowerPoint.Shape

  ' 「プレゼンテーションの表示」は「標準」にしてください
  Set pptDocWnd = PowerPoint.Application.ActiveWindow
  Set pptSldRng = pptDocWnd.Selection.SlideRange
  Set pptPr = pptSldRng.Parent
  ' 選択されているスライドは1枚だけにしてください
  Set pptSld = pptPr.Slides(pptSldRng.SlideIndex)
  Set pptShps = pptSld.Shapes

  Dim xls As Excel.Application
  Dim xlsRng As Excel.Range

  Dim pts() As Single ' スライド上の座標[pt]
  Dim N As Long ' セル選択範囲の行数
  Dim i As Long

  Set xls = VBA.Interaction.GetObject(Class:="Excel.Application")

  ' セルや数式バーが編集中でないことを確認してください
  Set xlsRng = xls.Application.ActiveWindow.RangeSelection
  N = xlsRng.Rows.Count

  ReDim pts(1 To N, 1 To 2)

  For i = 1 To N Step 1
    pts(i, 1) = MillimetersToPoints(xlsRng.Cells(i, 1).Value)
    pts(i, 2) = pptPr.PageSetup.SlideHeight - MillimetersToPoints(xlsRng.Cells(i, 2).Value)
  Next i

  Set pptShp = pptShps.AddPolyline(pts)

  Set xlsRng = Nothing
  Set xls = Nothing

End Sub