form1.frm

内含摇摆的sierpinski垫片源代码。双击F_move05.exe文件

VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H8000000A&
   Caption         =   "IFS动画（分形频道：fractal.cn）2004"
   ClientHeight    =   7260
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   10155
   LinkTopic       =   "Form1"
   ScaleHeight     =   7260
   ScaleWidth      =   10155
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command2 
      Caption         =   "退  出"
      Height          =   375
      Left            =   9000
      TabIndex        =   2
      Top             =   960
      Width           =   975
   End
   Begin VB.CommandButton Command1 
      Caption         =   "绘  制"
      Height          =   375
      Left            =   9000
      TabIndex        =   1
      Top             =   360
      Width           =   975
   End
   Begin VB.PictureBox Picture1 
      BackColor       =   &H80000017&
      Height          =   6975
      Left            =   120
      ScaleHeight     =   6915
      ScaleWidth      =   8595
      TabIndex        =   0
      Top             =   120
      Width           =   8655
   End
   Begin VB.PictureBox Picture2 
      Height          =   1455
      Left            =   5040
      ScaleHeight     =   1395
      ScaleWidth      =   555
      TabIndex        =   3
      Top             =   2520
      Width           =   615
   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 SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

Dim PixelToTwip_X As Single
Dim PixelToTwip_Y As Single

Private Sub ifs(k As Single, n As Long, pic As PictureBox)
  Dim x As Single, y As Single '仿射变换中的自变量
  Dim newx As Single, newy As Single '仿射变换产生的新点
  Dim a As Single, b As Single, c As Single, d As Single, e As Single, f As Single '仿射变幻中的系数
 
  Dim R As Single '随机变量
  Dim m(7, 7) '存放IFS码
  
  Randomize Timer
  x = 0: y = 0
  
 
 'IFS码赋值
  m(0, 0) = 0.5:   m(0, 1) = 0#:  m(0, 2) = 0:  m(0, 3) = 0.5:  m(0, 4) = 0#:   m(0, 5) = 0#:  m(0, 6) = 0.333
  m(1, 0) = 0.5:   m(1, 1) = 0#:  m(1, 2) = 0#:  m(1, 3) = 0.5:  m(1, 4) = 0.5:  m(1, 5) = 0#:  m(1, 6) = 0.333
  m(2, 0) = 0.5:   m(2, 1) = k:  m(2, 2) = 0:  m(2, 3) = 0.5:  m(2, 4) = 0.25: m(2, 5) = 0.5: m(2, 6) = 0.334
 
 '循环迭代，在不同的概率空间下，赋不同的IFS码值
  While n > 0
        R = Rnd
    Select Case R
      Case Is <= m(0, 6)
         a = m(0, 0): b = m(0, 1): c = m(0, 2): d = m(0, 3): e = m(0, 4): f = m(0, 5)
      Case Is <= (m(0, 6) + m(1, 6))
         a = m(1, 0): b = m(1, 1): c = m(1, 2): d = m(1, 3): e = m(1, 4): f = m(1, 5)
      Case Is <= (m(0, 6) + m(1, 6) + m(2, 6))
         a = m(2, 0): b = m(2, 1): c = m(2, 2): d = m(2, 3): e = m(2, 4): f = m(2, 5)
      Case Is <= (m(0, 6) + m(1, 6) + m(2, 6) + m(3, 6))
         a = m(3, 0): b = m(3, 1): c = m(3, 2): d = m(3, 3): e = m(3, 4): f = m(3, 5)
    End Select
      newx = (a * x) + (b * y) + e
      newy = (c * x) + (d * y) + f
      x = newx: y = newy
      DoEvents
     
      
      SetPixelV pic.hdc, (2000 + 4000 * x) / PixelToTwip_X, (5000 - 4000 * y) / PixelToTwip_Y, _
      RGB(Abs(k * 256) Mod 256, Abs(x * 150) Mod 256, Abs(y * 200) Mod 256)
      n = n - 1
      
  Wend
  
End Sub


Private Sub Command1_Click()
 Dim k As Single, n As Long, i As Integer, j As Integer
 Dim MemDC As Long
 
 
 k = 0
 n = 30000
 
 Call ifs(k, n, Picture1)
 For j = 1 To 3
  For i = 1 To 100
    n = n + 6000
    If i > 0 And i <= 25 Then k = k + 0.01
    If i > 25 And i <= 75 Then k = k - 0.01
    If i > 75 Then k = k + 0.01

    Call ifs(k, n, Picture2)
    Picture1.PaintPicture Picture2.Image, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, vbSrcCopy
    Picture2.Cls
    Next
 Next

  n = 50000
  Call ifs(k, n, Picture1)
End Sub

Private Sub Command2_Click()
  End
End Sub

Private Sub Form_Load()
Picture1.AutoRedraw = False
With Picture2
.Left = Picture1.Left
.Top = Picture1.Top
.Height = Picture1.Height
.Width = Picture1.Width
.AutoRedraw = True
.BackColor = Picture1.BackColor
End With

PixelToTwip_X = Screen.TwipsPerPixelX
PixelToTwip_Y = Screen.TwipsPerPixelY
End Sub