2

サード パーティのアプリケーションからコピーした一連のフリーフォーム シェイプがあります。

これらのフリーフォーム シェイプは、開いたパスで構成されており、PowerPoint で「結合」することはできません (結合できるのは、閉じたパスで作成されたフリーフォームのみです)。

次のマクロは、選択されたすべての図形を処理し、それがフリーフォームの場合、閉じたパスでコピーを作成してから、元の図形を削除します。

    Sub close_poly()


        Dim myshp As Shape
        Dim mycol As String
        Dim mynode As ShapeNode

        Dim myxvals As Variant
        Dim myyvals As Variant

        Dim myxcol As String
        Dim myycol As String

        Dim myffb As FreeformBuilder
        Dim mynewshp As Shape
        Dim myname As String


        For Each myshp In ActiveWindow.Selection.ShapeRange

            With myshp
                If .Type = msoFreeform Then


                    '################ set all line segments to straight
                    '(makes things easier in my specific case but will not work in many)
                    nodecount = 1
                    While nodecount <= .Nodes.Count
                        .Nodes.SetSegmentType nodecount, msoSegmentLine
                        nodecount = nodecount + 1
                    Wend

                    '############## collect coordinates
                     myxcol = ""
                     myycol = ""
                    For Each mynode In myshp.Nodes
                       myxcol = myxcol & mynode.Points(1, 1) & ","
                       myycol = myycol & mynode.Points(1, 2) & ","
                    Next
                    myxcol = Left(myxcol, Len(myxcol) - 1)
                    myycol = Left(myycol, Len(myycol) - 1)

                    myxvals = Split(myxcol, ",")
                    myyvals = Split(myycol, ",")


                    '##############create new freeform


                    Set myffb = ActiveWindow.View.Slide.Shapes.BuildFreeform(msoEditingAuto, myxvals(0), myyvals(0))
                        For i = 1 To UBound(myxvals)
                            myffb.AddNodes msoSegmentLine, msoEditingAuto, myxvals(i), myyvals(i)
                        Next i
                        myffb.AddNodes msoSegmentLine, msoEditingAuto, myxvals(0), myyvals(0)
                    Set mynewshp = myffb.ConvertToShape

                    myshp.PickUp
                    mynewshp.Apply

                    myname = myshp.Name
                    myshp.Delete

                    mynewshp.Name = myname

                End If
            End With


        Next myshp
End Sub

質問: VBA でプログラムの「パスを閉じる」機能を模倣する簡単な方法はありますか?

乾杯

4

0 に答える 0