インストールレスプログラミング( ´ー`)

VBA , JavaScript , HTAなど 365アプリはインストール必要ですが、仕事に無いケースはほぼないから(・_・;)

スライド再現マクロ　経過②

Powerpoint VBA

chemiphys.hateblo.jp
つづきです。

けっこうがんばりました。

まだ途中ですが，スライド１のフリーフォームはおそらくきちんと再現し，フリーフォームを作るマクロをイミディエイトウィンドウに吐き出します。

他に表やテキストボックスもコード上の再現はできたので，あとはイミディエイトウィンドウにそれを作るマクロを吐き出させるよう，今後書きます。

全てを完全に再現する気はないのですが，

けっこう応用範囲が出てくる程度には作るつもり。

明日・明後日は時間がある程度確保できると思うので，それなりのレベルに持っていきたいな。

再現風景をGIFアニメで
f:id:chemiphys:20170127184721g:plain

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
            strText = "Text" & "," & s.Left & "," & s.Top & vbTab & _
                    s.Name & "," & s.Width & "," & s.Height & vbTab & _
                    s.Fill.ForeColor.RGB & "," & s.TextFrame.TextRange
            colShape.Add strText
    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"
            With TSlide2.Shapes.AddTextbox(msoTextOrientationHorizontal, Split(Split(colShape(i), vbTab)(0), ",")(1), _
              Split(Split(colShape(i), vbTab)(0), ",")(2), Split(Split(colShape(i), vbTab)(1), ",")(1), Split(Split(colShape(i), vbTab)(1), ",")(2))
                .Name = Split(Split(colShape(i), vbTab)(1), ",")(0)
                .Fill.ForeColor.RGB = Split(Split(colShape(i), vbTab)(2), ",")(0)
                .TextFrame.AutoSize = ppAutoSizeNone
                .TextFrame.TextRange = Split(Split(colShape(i), vbTab)(2), ",")(1)
            End With
    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
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)
    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

End Sub
Sub d()
Dim x As Shape, i As Long
Set x = ActivePresentation.Slides(1).Shapes("slope")
    For i = 1 To x.Nodes.Count
        Debug.Print i, x.Nodes(i).Points(1, 1), x.Nodes(i).Points(1, 2), x.Nodes(i).EditingType, x.Nodes(i).SegmentType
    Next

End Sub