Private Sub DLA(r0 As Integer, p As Integer, q As Integer)
Dim r As Integer '可凝聚半径
Dim rmax As Integer '最大可凝聚半径
Dim rx As Integer '初始释放粒子的x坐标
Dim ry As Integer '初始释放粒子的y坐标
Dim x As Integer '粒子游走坐标x
Dim y As Integer '粒子游走坐标y
Dim xb As Integer '粒子在上一次游走坐标x
Dim yb As Integer '粒子在上一次游走坐标y
Dim twd(4) As Integer '记录游走粒子坐标
Dim c As Long '抹去游走粒子痕迹所用的颜色
Dim d As Single '游走粒子与聚核中心的距离
c = Me.BackColor
Me.ForeColor = vbBlack
loop0:
r = r0 + 5
rmax = r0 + 10
Randomize (Time)
rx = Int((2 * r + 1) * Rnd) - r
ry = Int((2 * r + 1) * Rnd) - r
x = rx + p
y = ry + q
DoEvents
loop1:
xb = x
yb = y
d = Abs(x - p) - Abs(y - q)
If Point(x, y - 1) = vbBlack Or Point(x, y + 1) = vbBlack Or Point(x - 1, y) = vbBlack Or Point(x + 1, y) = vbBlack Then GoTo loop2
If d > rmax Then Me.PSet (x, y), c: GoTo loop0
twd(1) = 0
twd(2) = 0
twd(Int(2 * Rnd) + 1) = Sgn(Rnd - 0.5)
x = x + twd(1)
y = y + twd(2)
Me.PSet (xb, yb), c: Me.PSet (x, y)
GoTo loop1
loop2:
Me.PSet (x, y), vbBlack
If d > r0 Then r0 = d
GoTo loop0
End Sub
