form1.frm

分形计算

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "扩散有限凝聚模型（分形频道：fractal.cn）2004"
   ClientHeight    =   7275
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   9915
   LinkTopic       =   "Form1"
   ScaleHeight     =   485
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   661
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command2 
      Caption         =   "退  出"
      Height          =   375
      Left            =   8760
      TabIndex        =   1
      Top             =   960
      Width           =   1095
   End
   Begin VB.CommandButton Command1 
      Caption         =   "绘  制"
      Height          =   375
      Left            =   8760
      TabIndex        =   0
      Top             =   480
      Width           =   1095
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Sub DLA(R As Integer, p As Integer, q As Integer, v As Integer)
  
  Dim Rmax As Integer
  Dim Rx As Integer
  Dim Rv As Integer
  Dim Ry As Integer
  Dim Xb As Integer
  Dim Yb As Integer
  Dim x As Integer
  Dim y As Integer
  Dim twd(4) As Integer
  Dim C As Long
  Dim d As Single
  Dim m As Single
      
  C = Me.BackColor
  Me.ForeColor = vbBlack
  d = v
        
loop0:
  Randomize (Time)
  m = (p + q) / 2
  Rx = Int((2 * m + 1) * Rnd) - m             'x方向随机范围
  Ry = d - R
  x = Rx + p
  y = Ry
  DoEvents
  
Loop1:
  Xb = x: Yb = y
 
  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 x < (p - 100) Or x > (q + 100) Then Me.PSet (x, y), C: GoTo loop0 '超出直线左右的范围的点，将被抹掉
  twd(1) = Sgn(Rnd - 0.5): twd(2) = Int(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
   d = y
   GoTo loop0
  
End Sub

Private Sub Command1_Click()
  Dim p As Integer, q As Integer, R As Integer, v As Integer
  Me.ScaleMode = 3
  Me.DrawWidth = 1
  p = 200: q = 395: v = 400: R = 50
 
  Me.BackColor = vbWhite
  
  Me.Line (p - 100, v)-(q + 100, v)
  Call DLA(R, p, q, v)
End Sub

Private Sub Command2_Click()
  End
End Sub