はじめに
前回波線を描いたので今回はそれを利用して水面を描いてみました。
touch-sp.hatenablog.com
結果
後述のVBAコードを実行すると2枚のスライドができます。それをアニメーションGIFで保存したものを示します。
「体の60%は水でできている」を表すよく見かける図です。
VBAコード
Sub 水面を描く() ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutBlank ActiveWindow.View.GotoSlide Index:=1 Dim sld_w As Single ''スライドの横幅 Dim sld_h As Single ''スライドの高さ sld_w = ActivePresentation.PageSetup.SlideWidth sld_h = ActivePresentation.PageSetup.SlideHeight '顔 With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeOval, 245, 120, 75, 75) .Line.Visible = msoFalse .Select End With '肩 With ActivePresentation.Slides(1).Shapes.AddShape(msoShapePie, 200, 200, 80, 80) .Adjustments.Item(1) = 180 .Adjustments.Item(2) = 0 .Line.Visible = msoFalse .Select Replace:=msoFalse End With With ActivePresentation.Slides(1).Shapes.AddShape(msoShapePie, 280, 200, 80, 80) .Adjustments.Item(1) = 180 .Adjustments.Item(2) = 0 .Line.Visible = msoFalse .Select Replace:=msoFalse End With '胴体 With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 240, 200, 80, 170) .Line.Visible = msoFalse .Select Replace:=msoFalse End With '腕 With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 200, 239.5, 30, 120) .Line.Visible = msoFalse .Select Replace:=msoFalse End With With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 330, 239.5, 30, 120) .Line.Visible = msoFalse .Select Replace:=msoFalse End With '手 With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeOval, 200, 345.5, 30, 30) .Line.Visible = msoFalse .Select Replace:=msoFalse End With With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeOval, 330, 345.5, 30, 30) .Line.Visible = msoFalse .Select Replace:=msoFalse End With '足 With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 240, 369.5, 35, 140) .Line.Visible = msoFalse .Select Replace:=msoFalse End With With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 285, 369.5, 35, 140) .Line.Visible = msoFalse .Select Replace:=msoFalse End With With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeOval, 240, 492, 35, 35) .Line.Visible = msoFalse .Select Replace:=msoFalse End With With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeOval, 285, 492, 35, 35) .Line.Visible = msoFalse .Select Replace:=msoFalse End With 'すべてをマージして名前を付ける With ActiveWindow.Selection.ShapeRange .MergeShapes msoMergeUnion .Select End With With ActiveWindow.Selection.ShapeRange .Name = "man" .Align msoAlignCenters, msoTrue '.Align msoAlignMiddles, msoTrue .Fill.ForeColor.RGB = RGB(217, 217, 217) End With Dim image_height As Single Dim image_left As String image_height = ActiveWindow.Selection.ShapeRange.Height image_left = ActiveWindow.Selection.ShapeRange.Left ActiveWindow.Selection.ShapeRange.Top = sld_h - image_height ActivePresentation.Slides(1).Shapes("man").Copy With ActivePresentation.Slides(1).Shapes.Paste .Left = image_left .Top = sld_h - image_height .Select End With ActiveWindow.Selection.ShapeRange.Name = "man2" '========================1枚目のスライドを複製======================== ActivePresentation.Slides(1).Duplicate '========================1枚目のスライドを複製======================== '波の図形を描く '====================各自で設定==================== Const n_point = 25 '頂点の数×3-2 Const wave_width = 40 Const r = 30 '====================各自で設定==================== Dim t, h, l, w As Single Dim wave_height(1 To 2) As Integer wave_height(1) = 10 wave_height(2) = -10 For slide_index = 1 To 2 'スライドを選択 ActiveWindow.View.GotoSlide Index:=slide_index '=========================波の追加========================= Dim pts(1 To n_point, 1 To 2) As Single '始点 pts(1, 1) = 0 pts(1, 2) = wave_width + wave_width * ((-1) ^ 1) '中継点 For i = 4 To n_point - 3 Step 3 pts(i, 1) = wave_width * 2 * (i \ 3) pts(i, 2) = wave_width + wave_width * ((-1) ^ (i Mod 2)) Next i '終点 pts(n_point, 1) = wave_width * 2 * (n_point \ 3) pts(n_point, 2) = wave_width + wave_width * ((-1) ^ (n_point Mod 2)) pts(2, 1) = pts(1, 1) + r pts(2, 2) = pts(1, 2) For i = 3 To n_point - 4 Step 3 pts(i, 1) = pts(i + 1, 1) - r pts(i, 2) = pts(i + 1, 2) pts(i + 2, 1) = pts(i + 1, 1) + r pts(i + 2, 2) = pts(i + 1, 2) Next i pts(n_point - 1, 1) = pts(n_point, 1) - r pts(n_point - 1, 2) = pts(n_point, 2) With ActivePresentation.Slides(slide_index).Shapes.AddCurve(SafeArrayOfPoints:=pts) .Line.Visible = msoFalse If wave_height(slide_index) > 0 Then .Flip msoFlipVertical End If .Select End With ActiveWindow.Selection.ShapeRange.Name = "wave" '下の図形を追加する ActivePresentation.Slides(slide_index).Shapes("wave").Height = Abs(wave_height(slide_index)) With ActiveWindow.Selection.ShapeRange .Align msoAlignCenters, msoTrue .Align msoAlignMiddles, msoTrue End With With ActivePresentation.Slides(slide_index).Shapes("wave") t = .Top h = .Height l = .Left w = .Width .Left = l - 40 End With If wave_height(slide_index) > 0 Then With ActivePresentation.Slides(slide_index).Shapes.AddShape(msoShapeRectangle, l, t + h, w, t) .Line.Visible = msoFalse .Select End With Else With ActivePresentation.Slides(slide_index).Shapes.AddShape(msoShapeRectangle, l, t, w, t + h) .Line.Visible = msoFalse .Select End With End If ActiveWindow.Selection.ShapeRange.Name = "box" ActivePresentation.Slides(slide_index).Shapes.Range(Array("box", "wave")).Select With ActiveWindow.Selection.ShapeRange .MergeShapes msoMergeCombine .Select End With ActiveWindow.Selection.ShapeRange.Name = "wave2" '波と人の画像をマージする ActivePresentation.Slides(slide_index).Shapes.Range(Array("wave2", "man2")).Select ActiveWindow.Selection.ShapeRange.MergeShapes msoMergeIntersect Next slide_index End Sub
上のコードを実行した後、アニメーションGIFで保存する必要があります。
この部分はどうしてもVBAで記述できませんでした。
動作環境
以下の環境で作成しています。
Windows 10 Office Home and Business 2019
