• 2009-07-28

    用代码在放映时画图 - [VBA代码分享]

    版权声明:转载时请以超链接形式标明文章原始出处和作者信息及本声明
    http://www.blogbus.com/pptaddins-logs/43116216.html

    在阅读下面的内容之前,您应当具备下面的一些知识:

    (1)基础的数学能力
    (2)基础的VBA语言能力
    (3)基本的算法能力

    当您有了上面的基础知识之后,您就可以开始下面神奇的代码之旅了。

    代码段一:绘正叶图

    Sub 绘正叶图()
    Dim r, x, y, i As Double
    Dim cx, cy
    Const PI = 3.1415926
    For i = 0 To 6.3 Step 0.1
        r = 4 * Cos(2 * i)
        x = r * Cos(i)
        y = r * Sin(i)
        If i = 0 Then
            cx = 320 + x * 50
            cy = 240 - y * 50
            'ActivePresentation.SlideShowWindow.View.DrawLine cx, cy, 320 + x * 50, 240 - y * 50
        Else
            ActivePresentation.SlideShowWindow.View.DrawLine cx, cy, 320 + x * 50, 240 - y * 50
        cx = 320 + x * 50
        cy = 240 - y * 50
        End If
    Next i
    End Sub

    代码二:绘钻石

    Sub 绘钻石()
    Dim x(50), y(50), Xc, Yc, tt, n, r, i, j
        Xc = 320
        Yc = 240
        r = 200
        n = 21
        tt = 2 * 3.14159 / n
        For i = 0 To n - 1
            x(i) = Xc + r * Cos(i * tt)
            y(i) = Yc - r * Sin(i * tt)
        Next i
        For i = 0 To n - 2
            For j = i + 1 To n - 1
                ActivePresentation.SlideShowWindow.View.DrawLine x(i), y(i), x(j), y(j)
            Next j
        Next i
    End Sub

    代码三:绘星形

    Sub 绘星形()
        a = 100
        b = 10
        x = a
        y = a
        For i = 0 To 10
            star x, y
            x = x + b
            y = y - b
        Next i
        x = a
        y = a
        For i = 0 To 10
            star x, y
            x = x - b
            y = y + b
        Next i
    End Sub
    Private Sub star(x, y)
        ActivePresentation.SlideShowWindow.View.DrawLine 320, 200 - y, 320 - x, 200
        ActivePresentation.SlideShowWindow.View.DrawLine 320 - x, 200, 320, 200 + y
        ActivePresentation.SlideShowWindow.View.DrawLine 320, 200 + y, 320 + x, 200
        ActivePresentation.SlideShowWindow.View.DrawLine 320 + x, 200, 320, 200 - y
    End Sub

     代码四:绘树形图

    Sub 绘树形图()
        a = 3.14 / 15#
        th = 3.14 / 12#
        '绘出树干
        ActivePresentation.SlideShowWindow.View.DrawLine 150, 400, 450, 400
        ActivePresentation.SlideShowWindow.View.DrawLine 285, 400, 300, 180
        ActivePresentation.SlideShowWindow.View.DrawLine 300, 180, 315, 400
        '用随机函数Rnd绘制树叶
        For i = 0 To 99
            Xc = 180 + Rnd * 200
            Yc = 100 + Rnd * 180
            For j = 0 To 12
                x = Xc + 20 * Cos(j * a + th)
                y = Yc - 20 * Sin(j * a + th)
                ActivePresentation.SlideShowWindow.View.DrawLine Xc, Yc, x, y
            Next j
        Next i
    End Sub

    代码五:绘漂亮像框

    Sub 绘漂亮像框()
        Const PI = 3.1415926
        Dim px, py, x, y, r, l, nn, i, n As Integer
        Dim x1(121), x2(121), y1(121), y2(121), cx, cy As Double
        Dim a As Double
        'PictDraw.Cls
        r = 35
        n = -1
        nn = 35
        i = 1
        For a = 0 To 2 * PI Step PI / 60
              
            x1(i) = CInt((1.1 * (r / 5 * Sin(8 * a) + r * Sin(2 * a)) * Cos(a)))
            y1(i) = CInt((0.85 * (r / 5 * Sin(8 * a) + r * Sin(2 * a)) * Sin(a)))
            x2(i) = CInt(((r / 5 * Sin(6 * a) + r * Sin(2 * a)) * Cos(a)))
            y2(i) = CInt(((r / 5 * Sin(6 * a) + r * Sin(2 * a)) * Sin(a)))
            i = i + 1
        Next a
        For px = 120 To 540 Step 60
            For py = 50 To 350 Step 60
                n = n + 1
                If px = 120 Or px = 540 Or py = 50 Or py = 350 Then
                    For i = 1 To 121
                        x = (x2(i) - x1(i)) / nn * n + x1(i)
                        y = (y2(i) - y1(i)) / nn * n + y1(i)
                        x = (x + px) / 2
                        y = (y + py) / 2
                        If i = 1 Then
                            cx = x
                            cy = y
                        Else
                            ActivePresentation.SlideShowWindow.View.DrawLine cx, cy, x, y
                    cx = x: cy = y
                        End If
                    Next i
                End If
            Next py
        Next px
    End Sub

    分享到:

    评论

  • With Application.ActivePresentation
    .SlideShowSettings.PointerColor = vbBlue
    .SlideShowWindow.View.DrawLine 100, 100, 200, 200
    End With
    这是我的代码,图形颜色还是默认的红色。
  • 手动设置ink color可以更改所绘图形的颜色,代码中设置pointercolor好像并不能更改颜色。

    这个代码还是有用的,比如可以应用于演讲时用鼠标绘图。。。不过就像你说的墨迹对象可控性更好。但是如手动使用墨迹的话,画出来的东东歪歪扭扭的。
    回复Tiger说:
    用PointerColor可以改变画笔的颜色,这个属性返回一个ColorFromat对象。
    您可以这样来写代码(放在过程的开头):
    ActivePresentation.SlideShowWindow.View.PointerColor = vbBlue
    或者这样:
    ActivePresentation.SlideShowWindow.View.PointerColor .RGB= vbBlue
    2009-08-02 18:44:06
  • 谢谢分享!
    很高兴发现你是江西高安人,我也是的。
    我也经常去PPT Heaven之类的网站,下载了几乎所有好的PPT作品。应该说你的PPT编程水平已经到了PPT前沿了:)

    我工作中有很多PPT应用,花的时间也比较多。不过我对PPT编程使用不多,下面是我以前做的一个加载宏:
    http://club.excelhome.net/viewthread.php?tid=175157&highlight=%2Bhxhgxy

    文中所述PPT show中绘图,就像是使用API函数绘图一样,图案不会真正绘制到slides上,切换应用程序回来,图案就消失了。
    代码中没有设置线条颜色,为什么自动为红色呢?
    回复Tiger说:
    非常高兴网路遇故知。您所推荐的贴子我看了,写得不错,最早见到类似的代码是Chirag Dalal的,不过更好的做法是把计时器部分封装在一个类中,这样就可以代码重用了。我所写的这几个代码纯粹是玩码,实际用处不大。要想保存所画图形,就需要用到“墨迹”对象,代码相对就要复杂很多。因为PPT中默认的画笔颜色是红色,所以画出来的图形是红的,要想改变画笔颜色,只需设置PointerColor的值即可。
    2009-08-02 14:56:18