Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。Word VBAも始めました。

スライド再現マクロ③一応ここまで

chemiphys.hateblo.jp
続きです。この試みはラスト。

自分がほしい分はだいたいできたのでここまで。

フリーフォームの再現,コード化の自動化がしたい。
表も同じように作りたい。
ボタンもできればなんとかしたい。

この程度が目標で始まった試み。

面白かったけどここまでで終わりです。

f:id:chemiphys:20170127221348p:plain
こんな絵をスライド1に私が書きました。

マクロに書かせたコードがこちら。後述のコードがイミディエイトウィンドウに書き出します。
最初のところの Acrivepresentation.Slides(2)の数字を変えれば,違うスライドにも図を描きます。
デフォでは2に書くようになっています。

Sub NewSub()
Dim pSlide As Slide: Set pSlide = ActivePresentation.Slides(2)

With pSlide.Shapes.BuildFreeform(msoEditingAuto, 7, 55)
        .AddNodes msoSegmentCurve, msoEditingCorner, 18, 37, 31, 59, 59, 79
        .AddNodes msoSegmentCurve, msoEditingCorner, 88, 98, 137, 133, 178, 172
        .AddNodes msoSegmentCurve, msoEditingCorner, 218, 210, 254, 278, 302, 310
        .AddNodes msoSegmentCurve, msoEditingCorner, 350, 343, 409, 352, 466, 369
        .AddNodes msoSegmentCurve, msoEditingCorner, 522, 387, 593, 407, 640, 414
        .AddNodes msoSegmentCurve, msoEditingCorner, 687, 422, 711, 412, 747, 415
        .AddNodes msoSegmentCurve, msoEditingCorner, 783, 417, 822, 426, 856, 430
        .AddNodes msoSegmentCurve, msoEditingCorner, 891, 434, 936, 424, 954, 438
        .AddNodes msoSegmentCurve, msoEditingCorner, 972, 452, 1059, 504, 962, 515
        .AddNodes msoSegmentCurve, msoEditingCorner, 866, 525, 508, 504, 373, 499
        .AddNodes msoSegmentCurve, msoEditingCorner, 239, 494, 215, 505, 156, 485
        .AddNodes msoSegmentCurve, msoEditingCorner, 97, 464, 44, 426, 17, 377
        .AddNodes msoSegmentCurve, msoEditingCorner, -10, 327, -6, 241, -8, 188
        .AddNodes msoSegmentCurve, msoEditingCorner, -10, 134, -5, 73, 7, 55
    .ConvertToShape
End With
pSlide.Shapes(pSlide.Shapes.Count).Name = "Freeform 6"
pSlide.Shapes(pSlide.Shapes.Count).Fill.ForeColor.RGB = 5296274

With pSlide.Shapes.BuildFreeform(msoEditingAuto, 279, 129)
        .AddNodes msoSegmentLine, msoEditingAuto, 342, 151
        .AddNodes msoSegmentLine, msoEditingAuto, 369, 213
        .AddNodes msoSegmentLine, msoEditingAuto, 345, 259
        .AddNodes msoSegmentLine, msoEditingAuto, 338, 262
        .AddNodes msoSegmentLine, msoEditingAuto, 262, 266
        .AddNodes msoSegmentLine, msoEditingAuto, 211, 209
        .AddNodes msoSegmentCurve, msoEditingCorner, 212, 188, 212, 168, 212, 147
        .AddNodes msoSegmentLine, msoEditingAuto, 279, 129
    .ConvertToShape
End With
pSlide.Shapes(pSlide.Shapes.Count).Name = "Freeform 8"
pSlide.Shapes(pSlide.Shapes.Count).Fill.ForeColor.RGB = 801924

    With pSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 183, 97, 34, 13)
        .Name = "Rectangle 9"
        .Fill.ForeColor.RGB = 13998939
        .TextFrame.AutoSize = ppAutoSizeNone
        .TextFrame.TextRange = ""
    End With

    With pSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 171, 130, 34, 13)
        .Name = "Rectangle 10"
        .Fill.ForeColor.RGB = 13998939
        .TextFrame.AutoSize = ppAutoSizeNone
        .TextFrame.TextRange = ""
    End With

   With pSlide.Shapes.AddTable(4, 3, 442.7664, 53.97504, 442.6916, 116.8)
       .Name = "Table 11"
        .Table.Cell(1, 1).Shape.TextFrame.TextRange = "ID"
        .Table.Cell(1, 1).Shape.Fill.ForeColor.RGB = 13998939
        .Table.Cell(1, 2).Shape.TextFrame.TextRange = "h"
        .Table.Cell(1, 2).Shape.Fill.ForeColor.RGB = 13998939
        .Table.Cell(1, 3).Shape.TextFrame.TextRange = "V"
        .Table.Cell(1, 3).Shape.Fill.ForeColor.RGB = 13998939
        .Table.Cell(2, 1).Shape.TextFrame.TextRange = "1"
        .Table.Cell(2, 1).Shape.Fill.ForeColor.RGB = 15720146
        .Table.Cell(2, 2).Shape.TextFrame.TextRange = "30"
        .Table.Cell(2, 2).Shape.Fill.ForeColor.RGB = 15720146
        .Table.Cell(2, 3).Shape.TextFrame.TextRange = "0"
        .Table.Cell(2, 3).Shape.Fill.ForeColor.RGB = 15720146
        .Table.Cell(3, 1).Shape.TextFrame.TextRange = "2"
        .Table.Cell(3, 1).Shape.Fill.ForeColor.RGB = 16248810
        .Table.Cell(3, 2).Shape.TextFrame.TextRange = "20"
        .Table.Cell(3, 2).Shape.Fill.ForeColor.RGB = 16248810
        .Table.Cell(3, 3).Shape.TextFrame.TextRange = "15"
        .Table.Cell(3, 3).Shape.Fill.ForeColor.RGB = 16248810
        .Table.Cell(4, 1).Shape.TextFrame.TextRange = "3"
        .Table.Cell(4, 1).Shape.Fill.ForeColor.RGB = 15720146
        .Table.Cell(4, 2).Shape.TextFrame.TextRange = "10"
        .Table.Cell(4, 2).Shape.Fill.ForeColor.RGB = 15720146
        .Table.Cell(4, 3).Shape.TextFrame.TextRange = "30になったよ"
        .Table.Cell(4, 3).Shape.Fill.ForeColor.RGB = 15720146
    End With
End Sub

いかがでしょうか。ある程度は作ってくれるんじゃないかな。
フリーフォームで作った図形は各ポイントを再現するので,かなり正確に再現しますが,書いている効果線ぽいやつのように,図形を回転させたりした場合,それはこのつくりでは反映されません。
回転に関する情報を読み取るように作り,再現コードも足せば簡単に実装はできます。

あと,大いにありうる円くらい実装すればよかったんですが,いまのところはしていません。簡単だとは思うんですが,すみません面倒でした。。

まぁ使おうと思う人がいるとは思えませんけど!ふつうは描けばいいので,利用目的が発生しそうな人があまりオモイツキマセン(゚▽゚*)

デフォでは,スライド2に作るようになっていますので,スライド2を準備していただくか,最初らへんでスライドを指定している数字を書き換えてもらえば指定のスライドに作ります。
フリーフォームをある程度自動で作るようになったので私は満足です。

マクロも事前にマクロがあれば,ボタンなどのクリック時の設定を書き換えようと試みるようになっています。

マクロを作るマクロ(?)は下記の通り。

Option Explicit
Const 出力スライド = 2

Sub メイン処理()
Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1)
Dim s As Shape, strText
Dim colShape As Collection: Set colShape = New Collection

'デバッグウィンドウへ------------------------------------------------------------------------------
    Debug.Print "Sub NewSub"
    Debug.Print "Dim pSlide As Slide: Set pSlide = ActivePresentation.Slides(" & 出力スライド & ")"
    Debug.Print
'--------------------------------------------------------------------------------------------------
For Each s In TSlide.Shapes
    If s.Type = msoFreeform Then
        colShape.Add StrFreeform(s)
    ElseIf s.Type = msoTable Then
        colShape.Add strTable(s)
    Else
        colShape.Add strOther(s)
    End If
Next

Dim TSlide2 As Slide: Set TSlide2 = ActivePresentation.Slides(2)
Dim i As Long, j As Long
Dim strNode As String, ff As FreeformBuilder, sf As Shape

For i = 1 To colShape.Count
    Select Case Split(Split(colShape(i), vbTab)(0), ",")(0)
        Case "Freeform"
            Call DrawFreeForm(colShape(i), TSlide2)
        Case "Table"
            Call DrawTable(colShape(i), TSlide2)
        Case "Text"
            Call DrawOther(colShape(i), TSlide2)
    End Select
Next
'デバッグウィンドウへ------------------------------------------------------------------------------
    Debug.Print "end sub"
'--------------------------------------------------------------------------------------------------

End Sub

Function StrFreeform(図形 As Shape) As String
    Dim 各ノード As ShapeNode
    StrFreeform = "Freeform" & "," & 図形.TextFrame.TextRange.Text & "," & 図形.ActionSettings(ppMouseClick).Run & vbTab & _
                    図形.Name & vbTab & _
                    図形.Fill.ForeColor.RGB
    
    For Each 各ノード In 図形.Nodes
        StrFreeform = StrFreeform & vbTab & CLng(各ノード.Points(1, 1)) & "," & CLng(各ノード.Points(1, 2)) & "," & 各ノード.SegmentType
    Next
End Function

Function strTable(図形 As Shape) As String
    Dim 各セル値() As String, i As Long, j As Long
    ReDim 各セル値(図形.Table.Rows.Count, 図形.Table.Columns.Count)
    
    strTable = "Table" & "," & 図形.Left & "," & 図形.Top & vbTab & _
                    図形.Name & "," & 図形.Width & "," & 図形.Height & vbTab & _
                    図形.Table.Rows.Count & "," & 図形.Table.Columns.Count
    
    Dim strTableValue As String
    For i = 1 To 図形.Table.Rows.Count
        For j = 1 To 図形.Table.Columns.Count
            strTableValue = strTableValue & vbTab & i & "■" & j & "■" & 図形.Table.Cell(i, j).Shape.TextFrame.TextRange & "■" & 図形.Table.Cell(i, j).Shape.Fill.ForeColor.RGB
        Next
    Next
    
    strTable = strTable & strTableValue
End Function

Function strOther(図形 As Shape) As String
    strOther = "Text," & 図形.Left & "," & 図形.Top & vbTab & _
                図形.Name & "," & 図形.Width & "," & 図形.Height & vbTab & _
                図形.Fill.ForeColor.RGB & "," & 図形.TextFrame.TextRange & "," & 図形.ActionSettings(ppMouseClick).Run
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(3, 0)), CLng(NodeValue(3, 1)))
    For i = 4 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
    sf.Name = NodeValue(1, 0)
    sf.Fill.ForeColor.RGB = CLng(NodeValue(2, 0))
    If NodeValue(0, 1) <> "" Then
        sf.TextFrame.TextRange.Text = NodeValue(0, 1)
        sf.TextFrame.TextRange.Font.Color = vbBlack
    End If
    If NodeValue(0, 2) <> "" Then
        sf.ActionSettings(ppMouseClick).Action = ppActionRunMacro
        sf.ActionSettings(ppMouseClick).Run = NodeValue(0, 2)
    End If
'デバッグウィンドウへ------------------------------------------------------------------------------
    Debug.Print "with pSlide.Shapes.BuildFreeform(msoEditingAuto, " & CLng(NodeValue(3, 0)) & ", " & CLng(NodeValue(3, 1)) & ")"
    For i = 4 To UBound(Split(strNode, vbTab))
        If CLng(NodeValue(i, 2)) = msoSegmentCurve And i <= UBound(Split(strNode, vbTab)) - 2 Then
           Debug.Print "        .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
            Debug.Print "        .AddNodes msoSegmentline, msoEditingauto, " & NodeValue(i, 0) & ", " & NodeValue(i, 1)
        End If
                
    Next
    Debug.Print "    .ConvertToShape"
    Debug.Print "end with"
    Debug.Print "pslide.shapes(pslide.shapes.count).Name = """ & NodeValue(1, 0) & """"
    Debug.Print "pslide.shapes(pslide.shapes.count).fill.forecolor.rgb = " & NodeValue(2, 0)
    If NodeValue(0, 1) <> "" Then
        Debug.Print "pslide.shapes(pslide.shapes.count).TextFrame.TextRange.Text =""" & NodeValue(0, 1) & """"
    End If
    If NodeValue(0, 2) <> "" Then
        Debug.Print "pslide.shapes(pslide.shapes.count).ActionSettings(ppMouseClick).Action = ppActionRunMacro"
        Debug.Print "pslide.shapes(pslide.shapes.count).ActionSettings(ppMouseClick).Run =""" & NodeValue(0, 2) & """"
    End If

    
    Debug.Print
'---------------------------------------------------------------------------------------------------
End Sub

Sub DrawTable(strTable As String, pSlide As Slide)
    Dim i As Long, j As Long, k As Long, TableValue() As Variant
    Dim st As Shape

    Dim TableRow As Long, TableColumn As Long
    TableRow = CLng(Split(Split(strTable, vbTab)(2), ",")(0))
    TableColumn = CLng(Split(Split(strTable, vbTab)(2), ",")(1))
    
    ReDim TableValue(1 To TableRow, 1 To TableColumn)
    For k = 3 To UBound(Split(strTable, vbTab))
        TableValue(CLng(Split(Split(strTable, vbTab)(k), "■")(0)), CLng(Split(Split(strTable, vbTab)(k), "■")(1))) = Split(Split(strTable, vbTab)(k), "■")(2) & "■" & Split(Split(strTable, vbTab)(k), "■")(3)
    Next
    
    Set st = pSlide.Shapes.AddTable(TableRow, TableColumn, Split(Split(strTable, vbTab)(0), ",")(1), Split(Split(strTable, vbTab)(0), ",")(2), _
              Split(Split(strTable, vbTab)(1), ",")(1), Split(Split(strTable, vbTab)(1), ",")(2))
    st.Name = Split(Split(strTable, vbTab)(1), ",")(0)


    For i = 1 To TableRow
        For j = 1 To TableColumn
            st.Table.Cell(i, j).Shape.TextFrame.TextRange = Split(TableValue(i, j), "■")(0)
            st.Table.Cell(i, j).Shape.Fill.ForeColor.RGB = CLng(Split(TableValue(i, j), "■")(1))
        Next
    Next
'デバッグウィンドウへ------------------------------------------------------------------------------
Debug.Print "   with pSlide.Shapes.AddTable(" & TableRow & ", " & TableColumn & ", " & Split(Split(strTable, vbTab)(0), ",")(1) & "," & Split(Split(strTable, vbTab)(0), ",")(2) & ", " & Split(Split(strTable, vbTab)(1), ",")(1) & " , " & Split(Split(strTable, vbTab)(1), ",")(2) & ")"
Debug.Print "       .Name = """ & Split(Split(strTable, vbTab)(1), ",")(0) & """"
For i = 1 To TableRow
    For j = 1 To TableColumn
        Debug.Print "        .Table.Cell(" & i & "," & j & ").Shape.TextFrame.TextRange = """ & Split(TableValue(i, j), "■")(0) & """"
        Debug.Print "        .Table.Cell(" & i & "," & j & ").Shape.Fill.ForeColor.RGB = " & CLng(Split(TableValue(i, j), "■")(1))
    Next
Next
Debug.Print "    end with"
'----------------------------------------------------------------------------------------------------
End Sub

Sub DrawOther(strContents As String, pSlide As Slide)
    Dim pLeft As Long, pTop As Long, pName As String, pWidth As Long, pHeight As Long, pColor As Long, pText As String, pRunMacro As String
    pLeft = Split(Split(strContents, vbTab)(0), ",")(1)
    pTop = Split(Split(strContents, vbTab)(0), ",")(2)
    pWidth = Split(Split(strContents, vbTab)(1), ",")(1)
    pHeight = Split(Split(strContents, vbTab)(1), ",")(2)
    pName = Split(Split(strContents, vbTab)(1), ",")(0)
    pColor = Split(Split(strContents, vbTab)(2), ",")(0)
    pText = Split(Split(strContents, vbTab)(2), ",")(1)
    pRunMacro = Split(Split(strContents, vbTab)(2), ",")(2)
    With pSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, pLeft, pTop, pWidth, pHeight)
        .Name = pName
        .Fill.ForeColor.RGB = pColor
        .TextFrame.AutoSize = ppAutoSizeNone
        .TextFrame.TextRange = pText
        If pRunMacro <> "" Then
            .ActionSettings(ppMouseClick).Action = ppActionRunMacro
            .ActionSettings(ppMouseClick).Run = pRunMacro
        End If
    End With
'デバッグウィンドウへ------------------------------------------------------------------------------
Debug.Print "    With pSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, " & pLeft & "," & pTop & "," & pWidth & ", " & pHeight & ")"
Debug.Print "        .Name = """ & pName & """"
Debug.Print "        .Fill.ForeColor.RGB = " & pColor
Debug.Print "        .TextFrame.AutoSize = ppAutoSizeNone"
Debug.Print "        .TextFrame.TextRange = """ & pText & """"
If pRunMacro <> "" Then
    Debug.Print "        .ActionSettings(ppMouseClick).Action = ppActionRunMacro"
    Debug.Print "        .ActionSettings(ppMouseClick).Run =""" & pRunMacro & """"
End If
Debug.Print "    end with"
Debug.Print
'--------------------------------------------------------------------------------------------------

End Sub

どれだけでも機能は実装可能だろうなぁと思いますが,それだけどんどん どんどんコードが長くなる。

わたしは満足なのでここまでです。

もちろん いろいろなイレギュラーには対応していません。

利用は自己責任でお願いします。遊びで組んでいるコードなので,責任は持てません。

面白かったなぁ。