用PPT生成同心圆
Sub test()
Call DeleteAllPictures
Call CreateConcentricCircles
End Sub
Sub DeleteAllPictures()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim i As Integer
' 获取当前活动的PowerPoint应用程序和演示文稿
Set pptApp = Application
Set pptPres = pptApp.ActivePresentation
' 遍历演示文稿的所有幻灯片
For Each pptSlide In pptPres.Slides
' 遍历幻灯片上的所有形状
For Each pptShape In pptSlide.Shapes
' 如果形状是图片,则删除它
'If pptShape.Type = msoPicture Then
pptShape.Delete
'End If
Next pptShape
Next pptSlide
End Sub
Sub CreateConcentricCircles()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim centerX As Single
Dim centerY As Single
Dim radius As Single
Dim circleCount As Integer
Dim i As Integer, arr()
Dim randomNumber As Integer
Dim ColorNumber As Integer
Dim red As Integer, green As Integer, blue As Integer
' 获取当前活动的PowerPoint应用程序和演示文稿
Set pptApp = Application
Set pptPres = pptApp.ActivePresentation
Set pptSlide = pptPres.Slides(1) ' 假设我们要在第一个幻灯片上添加同心圆
' 设置中心点坐标、半径和圆的数量
centerX = 350
centerY = 280
radius = 8
circleCount = 28
randomNumber = Int(Rnd * 6) '颜色排列组合中随机抽中一种
ColorNumber = Int(255 / circleCount) '随机因子
' 绘制同心圆
For i = circleCount To 1 Step -1
Set pptShape = pptSlide.Shapes.AddShape(msoShapeOval, centerX - radius * i, centerY - radius * i, radius * 2 * i, radius * 2 * i)
With pptShape
red = Int(Rnd * 256)
green = 255 - (i * ColorNumber)
blue = i * ColorNumber
' 设置填充颜色为渐变色
Select Case randomNumber
Case 0
.Fill.ForeColor.RGB = RGB(red, green, blue)
Case 1
.Fill.ForeColor.RGB = RGB(red, blue, green)
Case 2
.Fill.ForeColor.RGB = RGB(green, blue, red)
Case 3
.Fill.ForeColor.RGB = RGB(green, red, blue)
Case 4
.Fill.ForeColor.RGB = RGB(blue, green, red)
Case 5
.Fill.ForeColor.RGB = RGB(blue, red, green)
End Select
.Line.Visible = msoFalse ' 隐藏边框
End With
Next i
For i = 1 To circleCount
ReDim Preserve arr(i - 1)
arr(i - 1) = i
Next i
' 将同心圆组合在一起
pptSlide.Shapes.Range(arr).Group
'Ctrl+Shift拖动可以不改圆的形状放大或缩小
End Sub