スライド再現マクロ③一応ここまで
chemiphys.hateblo.jp
続きです。この試みはラスト。
自分がほしい分はだいたいできたのでここまで。
フリーフォームの再現，コード化の自動化がしたい。
表も同じように作りたい。
ボタンもできればなんとかしたい。
この程度が目標で始まった試み。
面白かったけどここまでで終わりです。
こんな絵をスライド１に私が書きました。
マクロに書かせたコードがこちら。後述のコードがイミディエイトウィンドウに書き出します。
最初のところの Acrivepresentation.Slides(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
いかがでしょうか。ある程度は作ってくれるんじゃないかな。
フリーフォームで作った図形は各ポイントを再現するので，かなり正確に再現しますが，書いている効果線ぽいやつのように，図形を回転させたりした場合，それはこのつくりでは反映されません。
回転に関する情報を読み取るように作り，再現コードも足せば簡単に実装はできます。
あと，大いにありうる円くらい実装すればよかったんですが，いまのところはしていません。簡単だとは思うんですが，すみません面倒でした。。
まぁ使おうと思う人がいるとは思えませんけど!ふつうは描けばいいので，利用目的が発生しそうな人があまりオモイツキマセン(ﾟ▽ﾟ*)
デフォでは，スライド２に作るようになっていますので，スライド２を準備していただくか，最初らへんでスライドを指定している数字を書き換えてもらえば指定のスライドに作ります。
フリーフォームをある程度自動で作るようになったので私は満足です。
マクロも事前にマクロがあれば，ボタンなどのクリック時の設定を書き換えようと試みるようになっています。
マクロを作るマクロ(?)は下記の通り。
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
どれだけでも機能は実装可能だろうなぁと思いますが，それだけどんどん どんどんコードが長くなる。
わたしは満足なのでここまでです。
もちろん いろいろなイレギュラーには対応していません。
利用は自己責任でお願いします。遊びで組んでいるコードなので，責任は持てません。
面白かったなぁ。
