オートシェイプの線の単純結合 - インストールレスプログラミング( ´ー`)

本当に久しぶりにパワーポイントのvbaネタです。

せっかく整理できたので，一つくらい書こうと思い，完全に忘れていたのでトライアンドエラーの末，うまく調整したらよくなりそうなものを載せてみます。

どなたかばっちりなものに作り上げてくれるのもありがたい。。

さて，パワーポイント等でお絵かきをよくするんですが，ドロー系のように，線の結合をしたいことがあります。

確かにパワーポイントには図形の結合なるものがあるんですが，

f:id:chemiphys:20180311161301p:plain

この状態で図形の結合をすると
f:id:chemiphys:20180311161350p:plain

(;´▽｀A``

そうじゃないんですよ

とても残念なことになります。

そこで，以前ベジェ曲線のことをやったなぁと思い，あれをうまく使えばいけるかな・・と　かなり適当にやっつけてみました。

使い方に気を付けないと想定通りいきませんが，気を付ければ使えるレベルになったので公開。

Sub test()
Dim TSld As Slide: Set TSld = ActiveWindow.Selection.ShapeRange(1).Parent
Dim Shape1 As Shape, Shape2 As Shape
Set Shape1 = ActiveWindow.Selection.ShapeRange(1)
Set Shape2 = ActiveWindow.Selection.ShapeRange(2)

Dim Col1 As New Collection, col2 As New Collection

Dim i As Long
For i = 1 To UBound(Split(StrFreeform(Shape1), vbTab))
    Col1.Add Split(StrFreeform(Shape1), vbTab)(i)
Next
For i = 1 To UBound(Split(StrFreeform(Shape2), vbTab))
    col2.Add Split(StrFreeform(Shape2), vbTab)(i)
Next


Dim col3 As New Collection
For i = 1 To Col1.Count
    col3.Add Col1(i)
Next

For i = 1 To col2.Count
    If i = 1 Then
        col3.Add Left(col2(i), Len(col2(i)) - 1) & "0"
    Else
        col3.Add col2(i)
    End If
Next

Dim str As String
For i = 1 To col3.Count
    str = str & vbTab & col3(i)
Next


DrawFreeForm str, TSld

End Sub

Function StrFreeform(図形 As Shape) As String
    Dim 各ノード As ShapeNode
    For Each 各ノード In 図形.Nodes
        StrFreeform = StrFreeform & vbTab & CLng(各ノード.Points(1, 1)) & "," & CLng(各ノード.Points(1, 2)) & "," & 各ノード.SegmentType
    Next
End Function

Sub DrawFreeForm(strNode As String, pSlide As Slide)
    Dim i As Long, j As Long, ff As FreeformBuilder, sf As Shape
    Dim NodeValue() As Variant
    ReDim NodeValue(UBound(Split(strNode, vbTab)), 3)
    
    For i = 0 To UBound(Split(strNode, vbTab))
        For j = 0 To UBound(Split(Split(strNode, vbTab)(i), ","))
            NodeValue(i, j) = Split(Split(strNode, vbTab)(i), ",")(j)
        Next
    Next

    Set ff = pSlide.Shapes.BuildFreeform(msoEditingAuto, CLng(NodeValue(1, 0)), CLng(NodeValue(1, 1)))
    For i = 2 To UBound(Split(strNode, vbTab))
        If CLng(NodeValue(i, 2)) = msoSegmentCurve And i <= UBound(Split(strNode, vbTab)) - 2 Then
            ff.AddNodes msoSegmentCurve, msoEditingCorner, NodeValue(i, 0), NodeValue(i, 1), NodeValue(i + 1, 0), NodeValue(i + 1, 1), NodeValue(i + 2, 0), NodeValue(i + 2, 1)
            i = i + 2
        Else
            ff.AddNodes msoSegmentLine, msoEditingAuto, NodeValue(i, 0), NodeValue(i, 1)
        End If
    Next
    Set sf = ff.ConvertToShape
End Sub

f:id:chemiphys:20180311161301p:plain
この位置関係だと，左の図形を先に選んで，shiftやらctrlキーを押しながらもう一つの図形を選んでください。選ぶ順番が影響します。

そしてtestマクロを実行すると，
f:id:chemiphys:20180311161849p:plain