Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。AdobeのScriptにも興味が少し。。

オートシェイプの線の単純結合

本当に久しぶりにパワーポイントの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

何が起こったかよくわかりませんね,ずらしてみると
f:id:chemiphys:20180311161955p:plain
f:id:chemiphys:20180311162037p:plain

ちゃんとノードを結合していきます。

選ぶ順番気を付けてくださいね。そこうまくつくれていません。

これが実用段階までいけば,何回かに分けて書いたオートシェイプのラインをきれいにつなげていけるものが出来上がるはず。

・・・

作る暇はないなぁ。。(;´▽`A``でも便利なものにはなりそうなんですけどね・・

公開後もうすこし試しましたが・・・まだまだ問題はけっこうありますね。

ノードの各順番によって想定通りうまくくっつかない。

でも,しくみがわかってれば図形を選ぶ順番である程度予測は付くかんじ。 二つとも中央から書いたらうまくいきませんが,一定の方向性をもってそれぞれの図形を書いていけばつかえるかなぁ。

今のところは自分用ですねぇ・・