型抜き

Sub Test002()

Dim sd As Slide, shp As Shape

Dim nsd As Long, nsp As Long

Dim x0 As Double, y0 As Double

Dim a As Double, b As Double, c As Double, d As Double, n As Long, i As Long

Dim x As Double, y As Double

nsd = ActiveWindow.Selection.SlideRange.SlideIndex

Dim s As String

Dim s0 As String

Dim s1 As String

Dim sp As Shape

Dim flg As Boolean

Dim rg As ShapeRange

Dim shp0 As Shape, shp1 As Shape

Dim nid As Long

x0 = 10 * 72 / 2.54

y0 = 10 * 72 / 2.54

a = 8 * 72 / 2.54

b = 2 * 72 / 2.54

c = 0.5 * 72 / 2.54

d = 0.5 * 72 / 2.54

n = 3

With ActivePresentation.Slides(nsd).Shapes.BuildFreeform(msoEditingCorner, x0, y0)

.AddNodes msoSegmentCurve, msoEditingCorner, x0 + a, y0, x0 + a, y0, x0 + a, y0

.AddNodes msoSegmentCurve, msoEditingCorner, x0 + a, y0 + b, x0 + a, y0 + b, x0 + a, y0 + b

.AddNodes msoSegmentCurve, msoEditingCorner, x0, y0 + b, x0, y0 + b, x0, y0 + b

.AddNodes msoSegmentCurve, msoEditingCorner, x0, y0, x0, y0, x0, y0

Set shp = .ConvertToShape

End With

nsp = ActivePresentation.Slides(nsd).Shapes.Count

s = "目的のもの" + Format(nsp, "0")

shp.Name = s

Set shp = ActivePresentation.Slides(nsd).Shapes(s)

Set shp1 = ActivePresentation.Slides(nsd).Shapes(s)

s0 = s

x = x0 + a / 2 + c - d / 2

y = y0 + b / 2 - d / 2

For i = 1 To n

Set shp = ActivePresentation.Slides(nsd).Shapes.AddShape(msoShapeOval, x, y, d, d)

nsp = ActivePresentation.Slides(nsd).Shapes.Count

s = "目的のもの" + Format(nsp, "0")

shp.Name = s

x = x + 2 * c

ActiveWindow.View.GotoSlide (nsd)

' ActivePresentation.Slides(nsd).Shapes(s0).Select

Set rg = ActivePresentation.Slides(nsd).Shapes.Range(Array(s0, s))

' MsgBox rg.Count

' MsgBox rg(1).Name

' MsgBox rg(2).Name

' MsgBox ActivePresentation.Slides(nsd).Shapes(s0).Id

' nid = ActivePresentation.Slides(nsd).Shapes(s0).Id

' rg.Select

' MsgBox "A"

rg.MergeShapes (msoMergeSubtract)

rg.Select

' MsgBox rg.Count

' MsgBox ActiveWindow.Selection.ShapeRange(1).Name

Set shp = ActiveWindow.Selection.ShapeRange(1)

s0 = shp.Name

' MsgBox shp1.Name

' MsgBox ActivePresentation.Slides(nsd).Shapes.Item(nid).Name

' MsgBox rg(1).Name

' MsgBox rg(1).Name

' MsgBox shp.Name

' Set shp = ActiveWindow.Selection.ShapeRange.MergeShapes(msoMergeSubtract, shp)

nsp = ActivePresentation.Slides(nsd).Shapes.Count

s = "合体した目的のもの" + Format(nsp, "0")

flg = True

Do While flg

For Each sp In ActivePresentation.Slides(nsd).Shapes

flg = False

If sp.Name = s Then

nsp = nsp + 1

s = "合体した目的のもの" + Format(nsp, "0")

flg = True

Exit For

End If

Next

Loop

shp.Name = s

s0 = shp.Name

Next i

End Sub