Powerpointのフリーフォーム（多角形）を直線に変換したい

なぜこんなものを？

オフィスの図形ツールに含まれているフリーフォームで図形を描くと、再編集したい場合にとても不便です。「頂点の編集」を利用するため水平垂直を保ったままの編集ができないことが最大の弱点です。

とはいえ、下図をトレースしたり、連続したいわゆるポリライン的なものを描いたりするときにはとても便利なのでCAD的にポンチ絵を描く際に「あー、この連続線を単線に分解したいなあ」と思うことがしょっちゅうあります。ということで、選択した図形の頂点を連続取得し、単線に分解するぷち機能を作りました。

導入

デフォルトのPowerpointではリボンの中に『開発タブ』が出ていないので、オプションのリボン設定から開発タブをONにし、VBEに貼り付けてください。

実際のコード

Sub 多角形を直線にする()
On Error GoTo ErrHandl

i = ActiveWindow.Selection.SlideRange.SlideIndex
With ActiveWindow.Selection.ShapeRange
    Weight = .Line.Weight
    SelectionColor = .Line.ForeColor
    R = Val("&H" & Left(Hex(SelectionColor And 255), 2))
    G = Val("&H" & Left(Hex(SelectionColor And (256 ^ 2 - 256 ^ 1)), 2))
    B = Val("&H" & Left(Hex(SelectionColor And (256 ^ 3 - 256 ^ 2)), 2))
    dash = .Line.DashStyle
    cnt = .Nodes.Count

    For j = 1 To cnt - 1
        vertArray = .Vertices
        x1 = vertArray(j, 1)
        y1 = vertArray(j, 2)
        x2 = vertArray(j + 1, 1)
        y2 = vertArray(j + 1, 2)

        With ActivePresentation.Slides(i).Shapes.AddLine(x1, y1, x2, y2)
            .Line.Weight = Weight
            .Line.ForeColor.RGB = RGB(R, G, B)
            .Line.DashStyle = dash
        End With
    Next j
End With

ActiveWindow.Selection.ShapeRange.Delete
Exit Sub

ErrHandl:
MsgBox "図形を選択してから実行してください。"
End Sub

使い方

このマクロが入ったPowerpointファイルのフリーフォームの図形を選択して、マクロを実行すると直線に分解されます。誤って何も選択しないばあいには怒られます。

よいPPTライフを。