Excel VBA練習 Excelセルの値を座標としてPowerPointスライドに描画

メモ

Excelセルの値を座標としてPowerPointスライドに描画する使い捨てマクロ。

• 選択されているExcelセル範囲
  • Excel.Application.ActiveWindow.RangeSelection
• 起動しているPowerPoint.Applicationの取得
  • VBA.Interaction.GetObject(Class:="PowerPoint.Application")
• 選択されているPowerPointスライド
  • PowerPoint.Application.ActiveWindow.Selection.SlideRange(1)

参考資料リンク

• GetObject function (Visual Basic for Applications) | Microsoft Docs
• Worksheet.SelectionChange event (Excel) | Microsoft Docs
• Shapes.BuildFreeform method (PowerPoint) | Microsoft Docs

使い捨てマクロ

' Excel 2019, Windows 11
' PowerPoint 2013

' GetObjectでPowerPoint.Applicationを取得して
' スライドに書き込みを行うので、
' 不要なPowerPointは終了してください。

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
  ' 選択範囲の確認用。
  ' Shapes.AddCurve methodでは点の個数を3n+1にする必要があるため。
  Dim N As Long, p As Long, q As Long

  N = Target.Rows.Count
  p = (N - 1) \ 3
  q = (N - 1) Mod 3

  Debug.Print "SelectionChange"
  Debug.Print "N = (3*" & p & "+1) + " & q
End Sub

Public Sub AddCurve()
  Draw "DrawCurve"
End Sub

Public Sub AddPolyline()
  Draw "DrawPolyline"
End Sub

Public Sub BuildFreeform()
  Draw "DrawFreeform"
End Sub

Private Sub Draw(ByVal funcName As String)
  Dim xlsRange As Excel.Range
  Dim N As Long
  Dim pptPts() As Single
  Dim pptPtsEditingType() As Long
  Dim pptPtsSegmentType() As Long
  Dim i As Long
  Dim str As String

  Dim pptApplication As Object ' As PowerPoint.Application
  Dim pptPresentation As Object ' As PowerPoint.Presentation
  Dim pptSlide As Object ' As PowerPoint.Slide
  Dim pptShape As Object ' As PowerPoint.Shape

  ' セルに入力されている数字の単位はcmとする。
  ' セルの選択範囲は2～4列で2行以上とする。
  ' 1列目 ... X[cm]
  ' 2列目 ... Y[cm]
  ' 3列目 ... EditingType (Auto, Corner)
  ' 4列目 ... SegmentType (Curve, Line)
  Set xlsRange = Excel.Application.ActiveWindow.RangeSelection
  N = xlsRange.Rows.Count

  ' 選択範囲が2行未満
  If N < 2 Then
    Debug.Print "選択範囲が2行未満"
    Debug.Assert False
  End If

  ' 選択範囲が2～4列ではない
  If (xlsRange.Columns.Count < 2) Or (xlsRange.Columns.Count > 4) Then
    Debug.Print "選択範囲が2～4列ではない"
    Debug.Assert False
  End If

  ' Shapes.AddCurve methodでは点の個数を3n+1にする必要がある
  If (funcName = "DrawCurve") And (((N - 1) Mod 3) <> 0) Then
    Debug.Print "(N - 1) Mod 3 = " & ((N - 1) Mod 3)
    Debug.Assert False
  End If

  On Error Resume Next
  ' 既に起動されているPowerPointを取得
  Set pptApplication _
    = VBA.Interaction.GetObject(Class:="PowerPoint.Application")
  On Error GoTo 0

  If pptApplication Is Nothing Then
    ' PowerPointを新たに起動
    Set pptApplication _
      = VBA.Interaction.CreateObject("PowerPoint.Application")

    ' プレゼンテーションを追加
    Set pptPresentation _
      = pptApplication.Presentations.Add

    ' PowerPointスライドのサイズを横29.7cm、縦21cmとする。
    pptPresentation.PageSetup.SlideWidth _
      = Excel.Application.CentimetersToPoints(29.7)

    pptPresentation.PageSetup.SlideHeight _
      = Excel.Application.CentimetersToPoints(21)

    ' PowerPointスライドのグリッドの設定
    pptPresentation.GridDistance _
      = Excel.Application.CentimetersToPoints(0.1)

    pptPresentation.Application.DisplayGridlines _
      = Office.MsoTriState.msoTrue

    ' スライドを追加
    Set pptSlide _
      = pptPresentation.Slides.AddSlide( _
        Index:=1, _
        pCustomLayout:=pptPresentation.Designs(1).SlideMaster.CustomLayouts(7) _
      )
  Else
    ' 既に起動されているPowerPointのスライドを取得
    Set pptSlide = pptApplication.ActiveWindow.Selection.SlideRange(1)
    Set pptPresentation = pptSlide.Parent
  End If

  ReDim pptPts(1 To N, 1 To 2)
  ReDim pptPtsEditingType(1 To N)
  ReDim pptPtsSegmentType(1 To N)

  For i = 1 To N Step 1
    ' PowerPointスライド左下の座標を(X,Y)=(0,0)とし、
    ' 右方向にXを正、上方向にYを正とする。

    ' 1列目 ... X[cm]
    pptPts(i, 1) _
      = pptPresentation.PageSetup.SlideWidth * 0 _
        + Excel.Application.CentimetersToPoints(xlsRange.Cells(i, 1).Value)

    ' 2列目 ... Y[cm]
    pptPts(i, 2) _
      = pptPresentation.PageSetup.SlideHeight * 1 _
        - Excel.Application.CentimetersToPoints(xlsRange.Cells(i, 2).Value)

    ' 3列目 ... EditingType (Auto, Corner)
    If xlsRange.Columns.Count >= 3 Then
      str = xlsRange.Cells(i, 3).Value
      If (str Like "Auto") Or (str Like "a") Then
        pptPtsEditingType(i) = Office.MsoEditingType.msoEditingAuto
      ElseIf (str Like "Corner") Or (str Like "c") Then
        pptPtsEditingType(i) = Office.MsoEditingType.msoEditingCorner
      Else
        pptPtsEditingType(i) = Office.MsoEditingType.msoEditingAuto
      End If
    Else
      pptPtsEditingType(i) = Office.MsoEditingType.msoEditingAuto
    End If

    ' 4列目 ... SegmentType (Curve, Line)
    If xlsRange.Columns.Count >= 4 Then
      str = xlsRange.Cells(i, 4).Value
      If (str Like "Curve") Or (str Like "c") Then
        pptPtsSegmentType(i) = Office.MsoSegmentType.msoSegmentCurve
      ElseIf (str Like "Line") Or (str Like "l") Then
        pptPtsSegmentType(i) = Office.MsoSegmentType.msoSegmentLine
      Else
        pptPtsSegmentType(i) = Office.MsoSegmentType.msoSegmentCurve
      End If
    Else
      pptPtsSegmentType(i) = Office.MsoSegmentType.msoSegmentCurve
    End If
  Next i

  Select Case funcName
    Case "DrawCurve"
      Set pptShape _
      = DrawCurve(pptPts, pptSlide)
    Case "DrawFreeform"
      Set pptShape _
      = DrawFreeform(pptPts, pptSlide, pptPtsEditingType, pptPtsSegmentType)
    Case "DrawPolyline"
      Set pptShape _
      = DrawPolyline(pptPts, pptSlide)
    Case Else
      Debug.Assert False
  End Select

  Set pptShape = Nothing
  Set pptSlide = Nothing
  Set pptPresentation = Nothing
  Set pptApplication = Nothing
End Sub

Private Function DrawCurve( _
  ByRef pptPts() As Single, _
  ByVal pptSlide As Object _
  ) As Object
  ' return: As PowerPoint.Shape

  Set DrawCurve = pptSlide.Shapes.AddCurve(pptPts)
End Function

Private Function DrawFreeform( _
  ByRef pptPts() As Single, _
  ByVal pptSlide As Object, _
  ByRef pptPtsEditingType() As Long, _
  ByRef pptPtsSegmentType() As Long _
  ) As Object
  ' return: As PowerPoint.Shape

  Dim pptFreeformBuilder As Object ' As PowerPoint.FreeformBuilder
  Dim N As Long
  Dim i As Long

  N = UBound(pptPts, 1) - LBound(pptPts, 1) + 1

  ' 座標の1点目
  Set pptFreeformBuilder _
    = pptSlide.Shapes.BuildFreeform( _
        EditingType:=pptPtsEditingType(1), _
        X1:=pptPts(1, 1), Y1:=pptPts(1, 2) _
      )

  ' 座標の2点目以降
  For i = 2 To N Step 1
    pptFreeformBuilder.AddNodes _
      SegmentType:=pptPtsSegmentType(i), _
      EditingType:=pptPtsEditingType(i), _
      X1:=pptPts(i, 1), Y1:=pptPts(i, 2)
  Next i

  Set DrawFreeform = pptFreeformBuilder.ConvertToShape()

  Set pptFreeformBuilder = Nothing
End Function

Private Function DrawPolyline( _
  ByRef pptPts() As Single, _
  ByVal pptSlide As Object _
  ) As Object
  ' return: As PowerPoint.Shape

  Set DrawPolyline = pptSlide.Shapes.AddPolyline(pptPts)
End Function