发信人: hunter__fox(雁回西楼)
整理人: winsy(2003-03-05 15:11:52), 站内信件
|
表单中对象：
pic :PictureBox
Silder1 :Silder（取值1 to 100)
Silder2 :Silder（取值0 to 100)
Silder3 :Silder（取值1 to 100)
Timer1 :Timer
Label1 :Label（Caption为“开始”）
这段代码中没有使用数据移位的方法，而是用另一个方法，相对而言，在大数据量的
情况下，它的优势很明显。
sub Drow1中
也许有人会在画线时用一个循环，"For n = 1 To cpoint - 1"
然后在里面Line 方法中的X2,Y2值用Iif(....)来做，因为这样不必写第二个Line 语句
了，但我这样做是因为不必每次去计算Iif()语句从而能更快些。
=====================================================================
#Const dbg = Flast
Private Type pointXY '各点的坐标信息数据结构
x As Integer
y As Integer
End Type
'以下变量的初始化工作在 Label1_Click 事件中完成
Dim ap() As pointXY '所有点坐标信息
Dim sleep() As pointXY '各点步长，可定义一个Type,它的X和Y只需 Byte 类型
Dim color() As Long '各组多边形绘制色
Dim colorsleep() As Byte '各组绘制颜色步长
Dim sleepcount() As Integer '各组绘制颜色系列杯记
Dim counts As Integer '几组多边形
Dim clines As Integer '尾线数
Dim cpoint As Integer '多边形有多少顶点
Dim nowline As Integer '当前要画第几条线
Dim blnclear As Boolean '是否清除尾线
Dim m As Integer, n As Integer, i As Integer
Function drow()
Dim m As Integer, n As Integer, i As Integer
Dim backline As Integer
'clear laste line
If blnclear Then
drow1 nowline, True
End If
'new point
'计算上一次画的线对应的指针
backline = IIf(nowline = 1, clines, nowline - 1)
With Me.pic
For m = 1 To counts
For n = 1 To cpoint
'计算新坐标前检查一下结果是否会出界
'If 语句有点长，能短点就好了
If ap(m, backline, n).x + sleep(m, n).x < 0 _
Or ap(m, backline, n).x + sleep(m, n).x > .ScaleWidth Then _
sleep(m, n).x = newsleep(ap(m, backline, n).x, .ScaleWidth)
If ap(m, backline, n).y + sleep(m, n).y < 0 _
Or ap(m, backline, n).y + sleep(m, n).y > .ScaleHeight Then _
sleep(m, n).y = newsleep(ap(m, backline, n).y, .ScaleHeight)
'新坐标
ap(m, nowline, n).x = ap(m, backline, n).x + sleep(m, n).x
ap(m, nowline, n).y = ap(m, backline, n).y + sleep(m, n).y
Next n
Next m
End With
'drow lines
drow1 nowline, False
nowline = IIf(nowline = clines, 1, nowline + 1)
End Function
Function drow1(drowline As Integer, blnclear As Boolean)
With Me.pic
For m = 1 To counts
.ForeColor = IIf(blnclear, 0, color(m))
.PSet 0, ap(m, drowline, 1).x, ap(m, drowline, 1).y, .ForeColor
For n = 1 To cpoint - 1
.Line 0, _
ap(m, drowline, n).x, _
ap(m, drowline, n).y, _
ap(m, drowline, n + 1).x, _
ap(m, drowline, n + 1).y, _
.ForeColor
'是否有人会把"n+1"写为"n + IIf(n = cpoint, 1 - cpoint, 1)"呢
Next n
.Line 0, _
ap(m, drowline, cpoint).x, _
ap(m, drowline, cpoint).y, _
ap(m, drowline, 1).x, _
ap(m, drowline, 1).y, _
.ForeColor
color(m) = nextcolor(color(m), m)
Next m
End With
End Function
Function nextcolor(color As Long, index As Integer) As Long
'这是一个颜色循环，经历了两次白色，其它6种纯色各一次
Select Case colorsleep(index)
Case 0
nextcolor = RGB(sleepcount(index), 255, 0)
Case 1
nextcolor = RGB(255, 255 - sleepcount(index), 0)
Case 2
nextcolor = RGB(255, sleepcount(index), sleepcount(index))
Case 3
nextcolor = RGB(255 - sleepcount(index), 255, 255)
Case 4
nextcolor = RGB(0, 255 - sleepcount(index), 255)
Case 5
nextcolor = RGB(sleepcount(index), 0, 255)
Case 6
nextcolor = RGB(255, sleepcount(index), 255)
Case 7
nextcolor = RGB(255 - sleepcount(index), 255, 255 - sleepcount(index))
Case Else
nextcolor = RGB(255, 255, 255)
sleepcount(index) = 0
colorsleep(index) = 1
End Select
sleepcount(index) = (sleepcount(index) + 4) Mod 256
colorsleep(index) = (colorsleep(index) + IIf(sleepcount(index) = 0, 1, 0)) _
Mod 8
End Function
Function newsleep(nowpoint As Integer, maxval As Integer) As Integer
Dim ret As Integer
Do
ret = Int(Rnd * 20 - 10)
'如果从最大化转为正常窗口，可以 maxval 会小于 nowpoint
If maxval < nowpoint Then
ret = -10 '大步向回跑吧
Exit Do
End If
Loop While nowpoint + ret < 0 Or nowpoint + ret > maxval Or ret = 0
newsleep = ret
End Function
'VB竟然没有 Max 函数？只好写一个了
Function Max(vVal1 As Variant, vVal2 As Variant) As Variant
Max = IIf(vVal1 > vVal2, vVal1, vVal2)
End Function
Private Sub Label1_Click() '初始化
Randomize Timer '重新初始化随机数种子
Me.Timer1.Interval = 0 '先停时钟
counts = Me.Slider1.Value '多边形有多少组
clines = Max(Me.Slider2.Value, 1) '尾线数，可能是0（不清除尾线）
blnclear = (Me.Slider2.Value > 0) '是零则不清尾线
cpoint = Me.Slider3.Value '多边形顶点数
'开始重定义数组
ReDim ap(1 To counts, 1 To clines, 1 To cpoint)
ReDim sleep(1 To counts, 1 To cpoint)
ReDim color(1 To counts)
ReDim colorsleep(1 To counts)
ReDim sleepcount(1 To counts)
'三个用于循环的变量
Dim m As Integer, n As Integer, i As Integer
For m = 1 To counts
'生成颜色
sleepcount(m) = Int(Rnd * 64) * 4
colorsleep(m) = Int(Rnd * 8)
color(m) = nextcolor(color(m), m)
For n = 1 To cpoint
'生成初始坐标和初始步长
ap(m, 1, n).x = Int(Rnd * Me.pic.ScaleWidth)
ap(m, 1, n).y = Int(Rnd * Me.pic.ScaleHeight)
sleep(m, n).x = newsleep(ap(m, 1, n).x, Me.pic.ScaleWidth)
sleep(m, n).y = newsleep(ap(m, 1, n).y, Me.pic.ScaleHeight)
For i = 2 To clines
'复制坐标到数组其它元素中
ap(m, i, n) = ap(m, 1, n)
Next i
Next n
Next m
'当前画线
nowline = 1
'清除绘制区
Me.pic.Cls
'启动时钟
Me.Timer1.Interval = 40
End Sub
Public Sub Form_Initialize()
Label1_Click
End Sub
Private Sub Form_Resize()
If Me.WindowState = 1 Then Exit Sub '最小化时不处理
With Me.pic
.Left = 0
.Top = 16
.Width = Me.ScaleWidth
.Height = Me.ScaleHeight - 16
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
Me.Timer1.Interval = 0
End Sub
Private Sub Timer1_Timer()
'最小化时不做事，即所谓，只做表面功夫
If Not (Me.WindowState = 1) Then Call drow
End Sub
----
作者：hunter__fox【雁回西楼】
※ 来源: 网易虚拟社区 广州站．
※ 个人天地 流水情怀[ccbyy] 灌水精英 NO:003
※ 编程开发 VFP[VFP] |
|