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

Excelセルの値を座標としてPowerPointスライドにフリーフォームを追加する使い捨てマクロ。

数式例

円弧

	A	B	C	D
1	= 0.5 + 0.1 * COS( PI()/2 - PI()/16*(ROW(A1)-1) )	= 0.1 + 0.1 * SIN( PI()/2 - PI()/16*(ROW(A1)-1) )	Auto	Curve

	A	B	C	D
1	= -0.5 + 0.1 * COS( PI()/2 + PI()/16*(ROW(A1)-1) )	= -0.1 + 0.1 * SIN( PI()/2 + PI()/16*(ROW(A1)-1) )	Auto	Curve

線

A	B	C	D
0.5	0	Auto	Line
0	0	Auto	Line

その他

A	B	C	D
1	1	Corner	Curve
1	-1	Corner	Curve
-1	-1	Corner	Curve
-1	1	Corner	Curve
1	1	Corner	Curve

A	B	C	D
1	1	Auto	Curve
1	-1	Auto	Curve
-1	-1	Auto	Curve
-1	1	Auto	Curve
1	1	Auto	Curve

参考資料リンク

• Shapes.BuildFreeform method (PowerPoint) | Microsoft Learn

使い捨てマクロ

GetObject関数でPowerPoint.Applicationオブジェクトへの参照を取得してスライドに書き込みを行うため、起動している不要なPowerPointを終了してください。

' Excel 2019, PowerPoint 2019, Windows 11 (2024年5月頃)

' 参照設定
' Microsoft Office 16.0 Object Library
' Microsoft PowerPoint 16.0 Object Library

' セルの選択範囲は4列で2行以上とする
' 1列目 ... X[cm]
' 2列目 ... Y[cm]
' 3列目 ... EditingType (文字列で Auto  または Corner)
' 4列目 ... SegmentType (文字列で Curve または Line  )

Option Explicit

#Const DEBUG_ = False

Public Sub Main()
  Dim xlRng As Excel.Range
  Dim N As Long
  Dim ppPts() As Single
  Dim ppPtsEditType() As Long, ppPtsSegType() As Long
  Dim i As Long
  Dim strEditingType As String, strSegmentType As String
  Dim msg As String, msgErr As New VBA.Collection

#If DEBUG_ Then
  Dim ppApp As PowerPoint.Application
  Dim ppPr As PowerPoint.Presentation
  Dim ppSld As PowerPoint.Slide
  Dim ppFfb As PowerPoint.FreeformBuilder
  Dim ppShp As PowerPoint.Shape
#Else
  Dim ppApp As Object
  Dim ppPr As Object
  Dim ppSld As Object
  Dim ppFfb As Object
  Dim ppShp As Object
#End If

  Set xlRng = Excel.Application.ActiveWindow.RangeSelection

  If xlRng.Columns.Count <> 4 Then
    VBA.Interaction.MsgBox Prompt:="選択範囲は4列にしてください"
    Exit Sub
  End If

  N = xlRng.Rows.Count

  If N < 2 Then
    VBA.Interaction.MsgBox Prompt:="選択範囲は2行以上にしてください"
    Exit Sub
  End If

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

  If ppApp Is Nothing Then
    ' PowerPointを新たに起動
    Set ppApp = VBA.Interaction.CreateObject("PowerPoint.Application")
    ppApp.Visible = Office.MsoTriState.msoTrue
    ' プレゼンテーションを追加
    Set ppPr = ppApp.Presentations.Add
    ' PowerPointスライドのサイズを横20cm、縦10cmとする
    ppPr.PageSetup.SlideWidth = 20 * 72 / 2.54
    ppPr.PageSetup.SlideHeight = 10 * 72 / 2.54
    ' PowerPointスライドのグリッドを0.1cmに設定
    ppPr.GridDistance = 0.1 * 72 / 2.54
    ppPr.Application.DisplayGridlines = Office.MsoTriState.msoTrue
    ' スライドを追加
    Set ppSld = ppPr.Slides.AddSlide(Index:=1, pCustomLayout:=ppPr.Designs(1).SlideMaster.CustomLayouts(7))
  Else
    Set ppSld = ppApp.ActiveWindow.Selection.SlideRange(1)
    Set ppPr = ppSld.Parent
  End If

  ReDim ppPts(1 To N, 1 To 2)
  ReDim ppPtsEditType(1 To N)
  ReDim ppPtsSegType(1 To N)

  For i = 1 To N Step 1
    VBA.Interaction.DoEvents

    ' PowerPointスライド中央の座標を(X,Y)=(0,0)とし、右方向にXを正、上方向にYを正とする。

    ' 1列目 ... X[cm]
    ppPts(i, 1) = ppPr.PageSetup.SlideWidth * 0.5 + xlRng.Cells(i, 1).Value2 * 72 / 2.54
    ' 2列目 ... Y[cm]
    ppPts(i, 2) = ppPr.PageSetup.SlideHeight * 0.5 - xlRng.Cells(i, 2).Value2 * 72 / 2.54
    ' 3列目 ... EditingType (Auto, Corner)
    strEditingType = xlRng.Cells(i, 3).Value2
    Select Case strEditingType
      Case "Auto"
        ppPtsEditType(i) = Office.MsoEditingType.msoEditingAuto
      Case "Corner"
        ppPtsEditType(i) = Office.MsoEditingType.msoEditingCorner
      Case Else
        ppPtsEditType(i) = Office.MsoEditingType.msoEditingAuto
        msgErr.Add Item:="行" & i & ": EditingType """ & strEditingType & """"
    End Select
    ' 4列目 ... SegmentType (Curve, Line)
    If i >= 2 Then
      strSegmentType = xlRng.Cells(i, 4).Value2
      Select Case strSegmentType
        Case "Curve"
          ppPtsSegType(i) = Office.MsoSegmentType.msoSegmentCurve
        Case "Line"
          ppPtsSegType(i) = Office.MsoSegmentType.msoSegmentLine
        Case Else
          ppPtsSegType(i) = Office.MsoSegmentType.msoSegmentLine
          msgErr.Add Item:="行" & i & ": SegmentType """ & strSegmentType & """"
      End Select
    End If
  Next i

  ' 座標の1点目
  Set ppFfb = ppSld.Shapes.BuildFreeform(EditingType:=ppPtsEditType(1), X1:=ppPts(1, 1), Y1:=ppPts(1, 2))

  ' 座標の2点目以降
  For i = 2 To N Step 1
    ppFfb.AddNodes SegmentType:=ppPtsSegType(i), EditingType:=ppPtsEditType(i), X1:=ppPts(i, 1), Y1:=ppPts(i, 2)
  Next i

  Set ppShp = ppFfb.ConvertToShape()
  ppShp.Fill.Visible = Office.MsoTriState.msoFalse

  msg = ""

  For i = 1 To msgErr.Count Step 1
    msg = msg & VBA.Constants.vbCrLf & msgErr(i)
  Next i

  VBA.Interaction.MsgBox Prompt:="描画完了" & VBA.Constants.vbCrLf & msg
End Sub

過去記事

dy100ms.hatenadiary.jp