PPT操作

最新推荐文章于 2024-08-22 16:59:00 发布

Fico fly

最新推荐文章于 2024-08-22 16:59:00 发布

阅读量130

点赞数 1

分类专栏： VBA 文章标签： powerpoint

本文链接：https://blog.csdn.net/qq_43156252/article/details/140059411

版权

VBA 专栏收录该内容

5 篇文章 1 订阅

订阅专栏

用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