frmtree.frm

一个可以生成美丽仿真树的软件源码,可以真真体现树的效果

VERSION 5.00
Begin VB.Form frmTree 
   AutoRedraw      =   -1  'True
   Caption         =   "Tree"
   ClientHeight    =   5070
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   6705
   Icon            =   "frmTree.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   ScaleHeight     =   5070
   ScaleWidth      =   6705
   WindowState     =   2  'Maximized
   Begin VB.Timer tmrFruits 
      Enabled         =   0   'False
      Interval        =   2000
      Left            =   1680
      Top             =   2430
   End
   Begin VB.PictureBox picBack 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   9060
      Index           =   4
      Left            =   5760
      Picture         =   "frmTree.frx":0442
      ScaleHeight     =   9000
      ScaleWidth      =   12000
      TabIndex        =   4
      TabStop         =   0   'False
      Top             =   2670
      Visible         =   0   'False
      Width           =   12060
   End
   Begin VB.PictureBox picBack 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   5820
      Index           =   3
      Left            =   4170
      Picture         =   "frmTree.frx":5B4F
      ScaleHeight     =   5760
      ScaleWidth      =   8010
      TabIndex        =   3
      TabStop         =   0   'False
      Top             =   3330
      Visible         =   0   'False
      Width           =   8070
   End
   Begin VB.PictureBox picBack 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   8160
      Index           =   2
      Left            =   2370
      Picture         =   "frmTree.frx":AB51
      ScaleHeight     =   8100
      ScaleWidth      =   11520
      TabIndex        =   2
      TabStop         =   0   'False
      Top             =   3450
      Visible         =   0   'False
      Width           =   11580
   End
   Begin VB.PictureBox picBack 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   6300
      Index           =   1
      Left            =   4920
      Picture         =   "frmTree.frx":DA48
      ScaleHeight     =   6240
      ScaleWidth      =   9000
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   1320
      Visible         =   0   'False
      Width           =   9060
   End
   Begin VB.PictureBox picBack 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   6180
      Index           =   0
      Left            =   3210
      Picture         =   "frmTree.frx":12D53
      ScaleHeight     =   6120
      ScaleWidth      =   9000
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   1980
      Visible         =   0   'False
      Width           =   9060
   End
   Begin VB.Image imgFruit2 
      Height          =   645
      Left            =   2130
      Picture         =   "frmTree.frx":17AB4
      Top             =   1620
      Visible         =   0   'False
      Width           =   750
   End
   Begin VB.Image imgFruit1 
      Height          =   645
      Left            =   870
      Picture         =   "frmTree.frx":181E7
      Top             =   1650
      Visible         =   0   'False
      Width           =   750
   End
   Begin VB.Image imgFlower 
      Appearance      =   0  'Flat
      Height          =   480
      Index           =   0
      Left            =   1590
      Picture         =   "frmTree.frx":1892B
      Stretch         =   -1  'True
      Top             =   1020
      Visible         =   0   'False
      Width           =   450
   End
End
Attribute VB_Name = "frmTree"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Const Pi As Single = 3.141592

Private Sub Form_Activate()
    ' when you move between Forms , this procedure became active, but I want to run it once, so I use goRender variable
    If goRender Then goRender = False: Call renderMe
End Sub


Private Sub renderMe()
    timerState (False) ' stop last actions of timer (if any).
    refreshMe

    Me.AutoRedraw = Not fastPaint ' disabling of this property make faster drawing, but your tree is not stable and when you move another Form on the Tree Form, the tree may be clear.
    goOut = False ' this variable is for manually stop
    myTree.currentStep = 0    ' this is the first step of function so it start from 0
    nextBranch Me.Width / 2, Me.Height - Me.Height / 5, 180
    
    If Not goOut And myTree.flowerNeed > 0 And myTree.fruitMaxChange > 0 Then timerState (True) ' activate Timer for changing flowers to fruits
    
    frmMain.cmdOK.Visible = True
    frmMain.cmdStop.Visible = False
    frmMain.ProgressBar.Value = 0
End Sub


' this procedure only clean Form and shows a new picture as background and reset some values
Private Sub refreshMe()
    Static newBackground As Byte
    
    myTree.currentProgress = 0  ' reset progress bar value in main form
    myTree.recisionValueHi = 0
    myTree.recisionValueLow = 0
    Call cleanFlowers
    Me.AutoRedraw = True
    Me.Cls
    If randomBackground Then newBackground = Int(Rnd(1) * 5)
    Me.PaintPicture picBack(newBackground).Picture, 0, 0, Me.Width, Me.Height, 0, 0, picBack(newBackground).Width, picBack(newBackground).Height
    DoEvents
End Sub

' this procedure remove flowers of last run, Me.Cls can't remove them because they are objects not paint.
Private Sub cleanFlowers()
    Dim j As Integer
        
    For j = 1 To imgFlower.UBound
        Unload imgFlower(j)
    Next
End Sub


' this is the main function that several times refer to itself
Private Function nextBranch(ByVal startX As Single, ByVal startY As Single, ByVal startAngle As Single) As Boolean
    On Error GoTo mustOut 'this is for overflow error controlling when size of a branche became very high in random states
    Dim j As Byte
    Dim branchSize As Single, branchWidth As Single
    Dim endX As Single, endY As Single, angleGrow As Single, newAngle As Single
    Dim branchCount As Single
    Dim branchColor As Long
    
    If myTree.currentStep >= myTree.totalSteps Or goOut Then Exit Function
    
    If myTree.currentStep = 3 Then ' for showing progressbar, and also "Cut Operation" in update 3, because of affecting by several items (BB,BPS,BPS Scale...), it's not too accurate at this time. any suggestion ?
        myTree.currentProgress = myTree.currentProgress + 100 / myTree.branchPerStep ^ myTree.currentStep
        frmMain.ProgressBar.Value = IIf(myTree.currentProgress < 100, myTree.currentProgress, 100)
        If myTree.cutOperation And myTree.currentProgress >= myTree.cutOperationValue Then myTree.totalSteps = 0: Exit Function
    End If
    
    If myTree.brokenBranches > 0 And myTree.currentStep > 2 Then If Rnd(1) * 100 < myTree.brokenBranches + (myTree.brokenBranches * ((myTree.brokenBranchesScale - 50) / 50) * ((myTree.currentStep * 2 - myTree.totalSteps) / myTree.totalSteps)) * 0.7 * (1 - (myTree.brokenBranchesScale - 50) / 100) Then Exit Function ' this is for making broken branches
    
    If myTree.recisionLevelHi > 0 And myTree.recisionValueHi = 0 And myTree.currentStep = myTree.recisionLevelHi - 1 Then myTree.recisionValueHi = startY ' this line and following are for recision level for higher branches