【目的】
パワーポイントを使用して、ロゴなどをベジェ曲線（フリーフォーム）で作成する際に、コントロールポイントが思った位置に配置できず困っていました。そこでVBAを使用して座標を数値として渡すことでフリーフォームが作れないか試行錯誤しました。ようやく思った通りの図形を作成することができましたので、備忘録としてここにまとめておきます。
【使用するサンプル図形】
サンプルの図形は2つ。一つは巴と言われる形です（図1）もう一つは、用具ブランドのロゴに似た形です（図2）
図1 すべて曲線のみです。一番上のポイントが開始点です。時計回りに図を描きます
図2 曲線と直線が混在しています。これも一番上のポイントが開始点です。時計回りに図を描きます
【頂点とコントロールポイント】
まず最初に、頂点とコントロールポイントの解析プログラムを使用して、どのようにデータが保存されているかを見てみます
プログラムNodeList（後述）を実行した結果が次の通りです
サンプル#1（曲線のみ）
頂点とコントロールポイントはこの図のとおり
これを解析すると次の表になります
サンプル#2（曲線・直線あり）
表の最後の列にある*の記号は、分かりやすくするために私がマークしました。
内部的には、頂点とコントロールポイントを区別するプロパティはありませんでした。
基本的なパターンは、頂点に二つのコントロールポイントが存在します。
コントロールポイント、頂点、コントロールポイントという組み合わせです。
（サンプル＃1のIndex4は2番目の頂点で、Index3と5がそのコントロールポイントとなります）
コントロールポイントが存在しない場合もあります。それは、直線（Line）の場合です。
（注意：頂点の編集モードにすると、画面上にはコントロールポイントが表示されますが、内部的には保有していません。）
直線の始点でそのひとつ前が曲線の場合は、コントロールポイントと頂点の2つです。（サンプル＃2のIndex6と7）
直線の終点でその後が直線の場合は、頂点のみです。 （サンプル＃2のIndex8）
直線の終点でその後が曲線の場合は、頂点とコントロールポイントの2つです。 （サンプル＃2のIndex9と10）
また、最初の頂点は、頂点とコントロールポイントの2つで、最後の頂点は、コントロールポイントと頂点の2つです。（直線のときを除く）
Edit（EditingType）は、コントロールポイントの働きを指定します。
・頂点を中心にスムージング（英語版：Smooth Point）
・頂点で線分を伸ばす（英語版： Straight Point）
・頂点を基準にする（英語版： Corner Point）
Smoothは、頂点がコントロールポイントの中間点になります
（サンプル＃1の開始点がこれにあたります。一方のコントロールポイントを移動すると、もう一方のコントロールポイントは頂点の反対側に自動で移動します）
Straightは、頂点がコントロールポイントの線上になりますが、距離が異なります
（サンプル＃1の2番目の頂点がこれにあたります。一方のコントロールポイントを移動すると、もう一方は頂点の延長線上になるように移動します）
Cornerは、二つのコントロールポイントが独立しています
（サンプル＃1の6番目の頂点がこれにあたります。コントロールポイントはそれぞれ自由に動かすことができます）
EditingTypeが”??”の項目がありますが、これは原因不明です。
値を取得することができませんでした。
Seg（SegmentType）は、直線か曲線かを指定します
詳細は、こちらをご覧ください
https://learn.microsoft.com/ja-jp/office/vba/api/powerpoint.shapenode
（ShapeNode オブジェクト (PowerPoint) | Microsoft Learn）
【プログラムを使って描画する CreatePoint関数】
入力するデータは､頂点ごとに必要となります。項目は次の8つ
・頂点のX座標
・頂点のY座標
・EditingType
・SegmentType
・頂点のひとつ前のコントロールポイントのX座標
・ 同 Y座標
・頂点のひとつ後ろのコントロールポイントのX座標
・ 同 Y座標
サンプルのパラメータは、視認性を意識して下記のような設定方法としました
注意点は次のとおり
・最初の頂点の項目5,6は不要のためゼロでOK
・最後の頂点の項目7,8は不要のためゼロでOK
・閉じた線を前提に作っています
・最初の頂点のEditingTypeは､BuildFreeformのルール上､Autoになるため何を指定しても問題ありません
･次が直線になる場合､項目7,8は不要のためゼロでOK
･直線の場合､項目5,6は不要のためゼロでOK
･EditingTypeは、マニュアル上は3（msoEditingSymmetric）が利用できることになっているが、このとき0（msoEditingAuto）とすること
↑不具合またはマニュアルの修正漏れと思われる
・EditingTypeをSmoothにしたとき、頂点がコントロールポイントの座標の中間点にならなければいけないので、そうなっていないときはプログラム上でコントロールポイント＃2のX、Y座標を修正しています（ログが出力されます）
・EditingTypeをStraightにしたとき、頂点がコントロールポイント間の線上にならなければいけないので、そうなっていないときはプログラム上でコントロールポイント＃2のY座標を修正しています（ログが出力されます）
注意事項
・下記関数は両方ともPowerpointのスライド#2を前提としています
・頂点が同じ座標は存在しないという前提で作られています
・閉じた図形を前提にしています
Sub CreatePoint()
Dim ww(19)
'msoEditingAuto 0
'msoEditingCorner 1
'msoEditingSmooth 2 = straight
'msoEditingSymmetric 3 = smooth(左右同じ)
'string xx, yy, SegType, EditType, CP1-X, CP1-Y, CP2-X, CP2-Y
'SegmentType: Line 0, Curve 1
'EditingType: Corner 1, Straight 2, Smooth 0 (3は使うとダメ Bug?)
ShapeN = "Sample1"
Select Case ShapeN
Case "Sample2"
ww(0) = Split("100 391 1 0 000 000 085 411")
ww(1) = Split("091 433 1 2 089 424 094 442")
ww(2) = Split("132 448 1 1 109 453 000 000")
ww(3) = Split("341 393 0 0 000 000 000 000")
ww(4) = Split("132 481 0 0 000 000 098 496")
ww(5) = Split("064 479 1 2 072 493 059 470")
ww(6) = Split("100 391 1 1 050 431 000 000")
Case "Sample1"
ww(0) = Split("200 400 1 0 000 000 250 400")
ww(1) = Split("300 500 1 2 300 450 300 525")
ww(2) = Split("250 550 1 0 275 550 225 550")
ww(3) = Split("200 500 1 0 200 525 200 475")
ww(4) = Split("150 450 1 0 175 450 125 450")
ww(5) = Split("100 500 1 1 100 475 100 450")
ww(6) = Split("200 400 1 0 150 400 000 000,")
Case Else
Debug.Print "ShapeN Error"
Exit Sub
End Select
For i = 0 To UBound(ww) 'wwMax
On Error Resume Next
If UBound(ww(i)) = 7 Then
If Err <> 0 Then Exit For
On Error GoTo 0
wwMax = i
Else
Exit For
End If
Next
'Smooth/Straightのとき､制御点1､頂点､制御点2が直線上にあるかどうかのチェック
For i = 1 To wwMax '1つ目はチェックしない
If ww(i)(2) <> 0 Then '直線は対象外
a1x = ww(i)(4): b1x = ww(i)(0): c1x = ww(i)(6)
a1y = ww(i)(5): b1y = ww(i)(1): c1y = ww(i)(7)
If i = wwMax Then '最後の頂点は最初の頂点と同じなので使う値は最初の頂点の制御点2
c1x = ww(0)(6)
c1y = ww(0)(7)
End If
Select Case ww(i)(3)
Case 0 ' Smooth
If c1x * 1 <> b1x + (b1x - a1x) Or c1y * 1 <> b1y + (b1y - a1y) Then
c1x = b1x + (b1x - a1x)
c1y = b1y + (b1y - a1y)
Debug.Print "頂点-" & i & "は制御点の中間ではありません。制御点2の座標を修正しました " & ww(i)(6) & "," & ww(i)(7) & " => " & c1x & "," & c1y
ww(i)(6) = c1x
ww(i)(7) = c1y
End If
Case 2 ' Straight
w01 = (b1y - a1y) / (b1x - a1x)
w02 = (c1y - b1y) / (c1x - b1x)
If w01 <> w02 Then
y = (b1y - a1y) * (c1x - b1x) / (b1x - a1x) + b1y
Debug.Print "頂点-" & i & "の制御点と頂点が直線ではありません。制御点2のY座標を修正しました " & ww(i)(7) & " => " & y
ww(i)(7) = y
End If
Case Else ' Corner
End Select
End If
Next
wName = "Free01"
Set myDocument = ActivePresentation.Slides(2)
'--- Step 1 頂点を設定してオブジェクトを作る ------------------------------
myDocument.Shapes(wName).Delete
idx = myDocument.Shapes.Count
With myDocument.Shapes.BuildFreeform(msoEditingAuto, ww(0)(0), ww(0)(1))
'Debug.Print 0, msoEditingAuto, "-", ww(0)(0), " ", ww(0)(1), ww(0)(4), " ", ww(0)(5), " ", ww(0)(6), " ", ww(0)(7)
For i = 1 To wwMax
If ww(i)(3) = 0 Then wEdit = 0 Else wEdit = ww(i)(3) ' Line -> Auto
Select Case wEdit
Case 0 ' Auto
.AddNodes ww(i)(2), ww(i)(3), ww(i)(0), ww(i)(1)
Case 1 ' Corner
.AddNodes ww(i)(2), ww(i)(3), ww(i)(4), ww(i)(5), ww(i)(6), ww(i)(7), ww(i)(0), ww(i)(1)
Case Else '
.AddNodes ww(i)(2), ww(i)(3), ww(i)(0), ww(i)(1)
End Select
'Debug.Print i, ww(i)(2), ww(i)(3), ww(i)(0), , " ", ww(i)(1), ww(i)(4), " ", ww(i)(5), " ", ww(i)(6), " ", ww(i)(7)
Next
.ConvertToShape
End With
DoEvents
myDocument.Shapes(idx + 1).Name = wName '"Free01"
'--- Step 2 制御点の編集 ------------------------------
Step2:
With myDocument.Shapes(wName).Nodes
wk = .Count
'Nodesの中は、頂点と制御点が両方格納されているので、頂点を調べる
'そして、それぞれの頂点ごとに、Nodesのインデックスを保存する
'これは、曲線だけならば頂点の前後は制御点となるが
'直線が含まれると頂点の次も頂点になることがあるため、確認なしに位置を修正できないため
Dim Summit() 'パラメータの数＝頂点の数なので、それぞれの頂点のNodesインデックスを保管
Dim SummitF() 'それぞれのNodesが頂点なのか否か
ReDim Summit(wwMax)
ReDim SummitF(wk)
For i = 0 To wk: SummitF(i) = 0: Next
For j = wwMax To 0 Step -1
Summit(j) = 0
For i = wk To 1 Step -1 '後ろからやる必要はないと思われるがそのまま使った
parr = .Item(i).Points
cx = Round(parr(1, 1), 2)
cy = Round(parr(1, 2), 2)
If cx = ww(j)(0) * 1 And cy = ww(j)(1) * 1 Then
'Debug.Print "Match", j, i, ww(j)(0), ww(j)(1)
wk = i - 1
Summit(j) = i '頂点JのNodesIndexを保存
SummitF(i) = 1
Exit For
Else
'Debug.Print "UnMatch", j, i, ww(j)(0), ww(j)(1), cX, cY
End If
Next
Next
'頂点の前後の制御点を修正する
For j = wwMax To 0 Step -1
i = Summit(j)
If j <> 0 Then
If SummitF(i - 1) <> 1 Then '
.SetPosition i - 1, ww(j)(4), ww(j)(5)
End If
End If
If j <> wwMax Then
If SummitF(i + 1) <> 1 Then
.SetPosition i + 1, ww(j)(6), ww(j)(7)
End If
End If
Next
End With
End Sub
解析プログラム
Sub NodeList(Optional ShapeName = "Free01")
'オブジェクトのNode一覧
'https://learn.microsoft.com/ja-jp/office/vba/api/powerpoint.shape.nodes
Set MyShape = ActivePresentation.Slides(2).Shapes(ShapeName)
With MyShape.Nodes
Debug.Print "ShapeName:" & MyShape.Name, "Node:" & MyShape.Nodes.Count
For i = 1 To .Count
parr = .Item(i).Points
cXvalue = parr(1, 1)
cYvalue = parr(1, 2)
On Error Resume Next
ET = "??"
ET = .Item(i).EditingType
ST = "??"
ST = .Item(i).SegmentType
On Error GoTo 0
Debug.Print i, cXvalue, cYvalue, ET, ST
Next i
End With
End Sub