エクセルからの型抜き

Dim ppAp As PowerPoint.Application

Dim pp As PowerPoint.Presentation

Dim sd As PowerPoint.Slide

Dim ppwin As PowerPoint.DocumentWindow

Dim ppshprg As PowerPoint.ShapeRange

Dim ppshp As PowerPoint.Shape

Dim shp1 As PowerPoint.Shape, shp2 As PowerPoint.Shape, shp3 As PowerPoint.Shape

Dim s1 As String, s2 As String

Set ppAp = New PowerPoint.Application

Set pp = ppAp.Presentations.Add

Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7))

'Shapeの設定順番を間違うと、透明の円になってしまうので注意

Set shp2 = sd.Shapes.AddShape(msoShapeOval, 335, 39, 194, 173)

Set shp1 = sd.Shapes.AddShape(msoShapeRectangle, 246.5, 87, 224.5, 197)

shp1.Name = "ss1"

shp2.Name = "ss2"

Set ppshprg = sd.Shapes.Range(Array("ss2"))

With ppshprg

.IncrementLeft 12.5

.IncrementTop -8.5

.Fill.Visible = msoFalse

.Line.Visible = msoFalse

End With

Set ppshprg = sd.Shapes.Range(Array("ss1", "ss2"))

For Each ppwin In ppAp.Windows

If ppwin.Presentation.Name = pp.Name Then

With ppwin

.Activate

.View.GotoSlide (sd.SlideIndex)

End With

ppshprg.Select

'ppshprg.MergeShapes (msoMergeSubtract)

' Set shp3 = ppshprg.MergeShapes(msoMergeIntersect, shp1)

ppshprg.MergeShapes msoMergeIntersect

'Selection.ShapeRange.MergeShapes msoMergeIntersect

'ppshprg.Select

'MsgBox ActiveWindow.Selection.ShapeRange.Count

'Set shp1 = ActiveWindow.Selection.ShapeRange(1)

' sd.Shapes(sd.Shapes.Count).Name = "型抜き"

End If

Next

End Sub