PowerPoint VBA練習 AddCurve

メモ

AddCurveで雲枠の一部分に見えそうな曲線を描くマクロ。

参考資料リンク

• Shapes.AddCurve method (PowerPoint) | Microsoft Docs

使い捨てマクロ

' PowerPoint 2013, Windows 10

Option Explicit

' マクロの表示(Alt+F8)で選択しやすくする
Public Sub 雲枠片を描画する()
  Draw
End Sub

Private Function CentimetersToPoints(ByVal centimeters As Double) As Double
  CentimetersToPoints = (72 / 2.54) * centimeters
End Function

Private Sub Draw()
  Const PI As Double = 3.14159265358979

  Dim pptSld As PowerPoint.Slide
  Dim pptShp As PowerPoint.Shape
  Dim pts() As Single

  ' 選択されているスライド1枚を取得
  Set pptSld = PowerPoint.Application.ActiveWindow.Selection.SlideRange(1)

  ' 曲線の座標に関する変数
  Dim r As Double
  Dim a As Double, b As Double

  Dim k As Long
  Dim N As Long

  r = 0.2
  a = 1
  b = 1.5

  ' InputBoxには数値が入力されるものとする
  N = VBA.Conversion.CLng(VBA.Interaction.InputBox(Prompt:="N"))

  ReDim pts(1 To 3 * N + 1, 1 To 2)

  pts(1, 1) = CentimetersToPoints(a * r * Cos(PI * 3 / 3))
  pts(1, 2) = CentimetersToPoints(b * r * Sin(PI * 3 / 3))

  For k = 1 To N Step 1
    ' 横方向
    pts(3 * k - 1, 1) = CentimetersToPoints(a * r * Cos(PI * 2 / 3) + (k - 1) * (2 * a * r))
    pts(3 * k + 0, 1) = CentimetersToPoints(a * r * Cos(PI * 1 / 3) + (k - 1) * (2 * a * r))
    pts(3 * k + 1, 1) = CentimetersToPoints(a * r * Cos(PI * 0 / 3) + (k - 1) * (2 * a * r))
    ' 縦方向
    pts(3 * k - 1, 2) = CentimetersToPoints(b * r * Sin(PI * 2 / 3))
    pts(3 * k + 0, 2) = CentimetersToPoints(b * r * Sin(PI * 1 / 3))
    pts(3 * k + 1, 2) = CentimetersToPoints(b * r * Sin(PI * 0 / 3))
  Next k

  ' 曲線の描画
  Set pptShp = pptSld.Shapes.AddCurve(SafeArrayOfPoints:=pts)

  pptShp.Line.Weight = 0.5
  pptShp.Line.ForeColor.RGB = VBA.Information.RGB(192, 0, 0)

End Sub