網路城邦
回本城市首頁 唐老鴨之家
市長:  副市長:
加入本城市推薦本城市加入我的最愛訂閱最新文章
udn城市資訊科技網路分享【唐老鴨之家】城市/討論區/
討論區Excel VBA 字體:
上一個討論主題 回文章列表 下一個討論主題
在powerpoint中繪製各種有趣的圖
 瀏覽666|回應0推薦0


等級:6
留言加入好友
Rem ===在 powerpoint 中以VBA程式繪製彩色隨機圖形(圓形)===


Sub Macro1()

For i = 1 To 100

    xx = Rnd * 640

    yy = Rnd * 460

    rr = Int(Rnd * 50 + 50)

    If xx + rr > 720 Or yy + rr > 540 Then GoTo ccc

   ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeOval, xx, yy, rr, rr).Select

   With ActiveWindow.Selection.ShapeRange

        .Fill.ForeColor.RGB = QBColor(Rnd * 15)

        .Line.ForeColor.RGB = QBColor(Rnd * 15)

        .Line.Weight = 5

        .Line.DashStyle = msoLineSolid

   End With

ccc:

Next i

End Sub


Rem ===在 powerpoint 中以VBA程式繪製彩色隨機圖形(矩形)===

Sub Macro2()

For i = 1 To 100

    xx = Rnd * 640

    yy = Rnd * 460

    ww = Rnd * 100 + 50

    hh = Rnd * 100 + 50

    If xx + ww > 720 Or yy + hh > 540 Then GoTo ccc

    ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, xx, yy, ww, hh).Select

    With ActiveWindow.Selection.ShapeRange

        .Fill.ForeColor.RGB = QBColor(Rnd * 15)

        .Line.ForeColor.RGB = QBColor(Rnd * 15)

    End With

ccc:

Next i

End Sub



Rem === 網狀圖形之一 ===

Sub Macro4()

a = 0: b = 0: c = 0: d = 0

Do While d < 720

ActiveWindow.Selection.SlideRange.Shapes.AddLine(a, 0, 720, b).Select

ActiveWindow.Selection.SlideRange.Shapes.AddLine(0, c, d, 540).Select

a = a + 20: b = b + 15: c = b: d = a

Loop

ActiveWindow.Selection.SlideRange.Shapes.AddLine(0, 540, 720, 540).Select

ActiveWindow.Selection.SlideRange.Shapes.AddLine(720, 0, 720, 540).Select

End Sub


Rem === 網狀圖形之二 ===

Sub Macro5()

inc1 = 18: inc2 = 13.5

X1 = 720: X2 = 0: Y1 = 270: Y2 = 270

Do While X1 >= X2

ActiveWindow.Selection.SlideRange.Shapes.AddLine(X1, 270, 360, Y1).Select

ActiveWindow.Selection.SlideRange.Shapes.AddLine(360, Y1, X2, 270).Select

ActiveWindow.Selection.SlideRange.Shapes.AddLine(X2, 270, 360, Y2).Select

ActiveWindow.Selection.SlideRange.Shapes.AddLine(360, Y2, X1, 270).Select

X1 = X1 - inc1

X2 = X2 + inc1

Y1 = Y1 - inc2

Y2 = Y2 + inc2

Loop

End Sub


Rem === 網狀圖形之三(可控制大小與位置) ===

Sub Macro6()

a = 0: b = 0: c = 0: d = 0

w = 360: h = 270: x = 180: y = 135 'width, height, x0, y0

Do While d < w

ActiveWindow.Selection.SlideRange.Shapes.AddLine(a + x, 0 + y, w + x, b + y).Select

ActiveWindow.Selection.SlideRange.Shapes.AddLine(0 + x, c + y, d + x, h + y).Select

a = a + w / 36: b = b + h / 36: c = b: d = a

Loop

ActiveWindow.Selection.SlideRange.Shapes.AddLine(0 + x, h + y, w + x, h + y).Select

ActiveWindow.Selection.SlideRange.Shapes.AddLine(w + x, 0 + y, w + x, h + y).Select

End Sub


Rem === 完全圖形(點數可變化) ===

Sub Macro7()

N = 12

RADIAN = 6.2832 / N

For x = 1 To N - 1

For y = x To N

X1 = Sin(x * RADIAN) * 320 + 360

Y1 = Cos(x * RADIAN) * 240 + 270

X2 = Sin(y * RADIAN) * 320 + 360

Y2 = Cos(y * RADIAN) * 240 + 270

ActiveWindow.Selection.SlideRange.Shapes.AddLine(X1, Y1, X2, Y2).Select

Next y

Next x

End Sub


Rem === 白努力雙曲線(幸運草) ===

Sub Macro8()

For i = 1 To 200

x0 = 360: y0 = 270

theta = i * 6.2832 / 200

r = 540 / 2 * Sin(2 * theta)

Rem  r = 540 / 2 * Cos(2 * theta)

x = 720 / 2 + r * Cos(theta)

y = 540 / 2 + r * Sin(theta)

ActiveWindow.Selection.SlideRange.Shapes.AddLine(x0, y0, x, y).Select

Next i

End Sub


Rem === 弦環圖形(點數,跨距可變化) ===

Sub Macro9()

N = 18

hop = 7

RADIAN = 6.2832 / N

For x = 1 To N - 1

For y = x + 1 To N

CX = Cos(x * RADIAN) * 240 + 360

SY = Sin(y * RADIAN) * 240 + 270

CY = Cos(y * RADIAN) * 240 + 360

SX = Sin(x * RADIAN) * 240 + 270

ee = y - x: ee2 = x + N - y

If ee = 1 Or ee = hop Or ee2 = 1 Or ee2 = hop Then

ActiveWindow.Selection.SlideRange.Shapes.AddLine(CX, SX, CY, SY).Select

ActiveWindow.Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 255)

End If

Next y

Next x

ActiveWindow.Selection.Unselect

End Sub


本文於 修改第 3 次
回應 回應給此人 推薦文章 列印 加入我的文摘

引用
引用網址:http://city.udn.com/forum/trackback.jsp?no=58536&aid=5238028