Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/sorts/pixel.frm

Visual Basic Form | 1999-08-12 | 5.4 KB | 150 lines

VERSION 5.00
Begin VB.Form Form1
   BackColor       =   &H00000000&
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   3690
   ClientTop       =   1020
   ClientWidth     =   4680
   ForeColor       =   &H00FFFFFF&
   LinkTopic       =   "Form1"
   ScaleHeight     =   213
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   312
   Begin VB.Timer Timer2
      Interval        =   10
      Left            =   3480
      Top             =   1920
   End
   Begin VB.Timer Timer1
      Enabled         =   0   'False
      Interval        =   10
      Left            =   720
      Top             =   2160
   End
   Begin VB.Label Label1
      BackStyle       =   0  'Transparent
      Caption         =   "Planet Source"
      BeginProperty Font
         Name            =   "Arial Narrow"
         Size            =   14.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000080FF&
      Height          =   285
      Left            =   1680
      TabIndex        =   0
      Top             =   840
      Width           =   1620
   End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
DefInt A-Z
Private cacheLabel_Left
Private cacheLabel_Top
Private cacheLabel_Bottom
Private cacheLabel_Right
Private ArraySize As Long
Private Sub Form_Load()
cacheLabel_Left = Label1.Left
cacheLabel_Right = (Label1.Left + Label1.Width)
cacheLabel_Top = Label1.Top
cacheLabel_Bottom = (Label1.Top + Label1.Height)
maxx = Label1.Width                          'get label width
maxy = Label1.Height + (Label1.Height / 2)   'get label height add extra height for flame
ReDim new_flame(maxx, maxy)                  'resize array to label
ReDim old_flame(maxx, maxy)
ArraySize = (maxx * maxy) * Len(new_flame(0, 0)) 'Get size of array for fast copy
End Sub
Private Sub Timer1_Timer()
'This is the main timer,  Displays and updates the flame
Dim x, y As Integer                           'store current x and y pos.
Dim red As Integer, green As Integer, blue As Integer                  'store colours
Dim c As Long, myHDC As Long
Dim stimer As Long
'This part generates the flame :)
stimer = gettickcount
For lps = 1 To 20
For x = 1 To maxx - 1
    For y = 1 To maxy - 1
    red = new_flame(x + 1, y).r             'Add up the surrounding red colours
    red = red + new_flame(x - 1, y).r
    red = red + new_flame(x, y + 1).r
    red = red + new_flame(x, y - 1).r

    green = new_flame(x + 1, y).g           'Add up the surrounding green colours
    green = green + new_flame(x - 1, y).g
    green = green + new_flame(x, y + 1).g
    green = green + new_flame(x, y - 1).g

    'uses the row above (y-1) to give the effect of moving up!
    If old_flame(x, y - 1).c = 0 Then   'if pixel is part of flame update
        tmp = (Rnd * Flame_Height)                      'pick a number from the air!
        r = red \ 4 - (tmp)
        If r > -1 Then
           old_flame(x, y - 1).r = r
        Else
           old_flame(x, y - 1).r = 0
        End If
        g = (green \ 4) - (tmp + 8) ' Average the green and decrease the colour
        If g > -1 Then
           old_flame(x, y - 1).g = g
        Else
           old_flame(x, y - 1).g = 0
        End If
    End If
    Next y
Next x
'This loop Displays and updates the array
  myHDC = hDC
c = 0
'new_flame = old_flame     ' update array VB6 only code
CopyMemory new_flame(0, 0).r, old_flame(0, 0).r, ArraySize 'update array
For x = 1 To maxx
   For y = 1 To maxy
'     new_flame(X, Y).r = old_flame(X, Y).r     ' update array
'     new_flame(X, Y).g = old_flame(X, Y).g
'     new_flame(X, Y).b = old_flame(X, Y).b
'     put the pixel!

      CopyMemory c, old_flame(x - 1, y).r, 3
      SetPixel myHDC, cacheLabel_Left + x, cacheLabel_Top + y, c
'     Me.PSet (Label1.Left + X, Label1.Top + Y - Int(Label1.Height / 2)), c 'RGB(new_flame(X - 1, Y).r, new_flame(X - 1, Y).g, new_flame(X - 1, Y).b)
   Next y
Next x
MsgBox gettickcount - stimer
End Sub
Private Sub Timer2_Timer()
    'This timer only initializes the array colours
    For x = 1 To maxx
     For y = 1 To maxy
          If Point(Label1.Left + x, Label1.Top + Label1.Height - y) <> 0 Then ' is there any colour at this point
           new_flame(x, maxy - y).r = 255   ' Set colour to Yellow
           new_flame(x, maxy - y).g = 255
           new_flame(x, maxy - y).b = 0
           new_flame(x, maxy - y).c = True  ' Is a permenant colour
          Else
           new_flame(x, maxy - y).r = 0
           new_flame(x, maxy - y).g = 0
           new_flame(x, maxy - y).b = 0
           new_flame(x, maxy - y).c = False ' Can be any colour
          End If

          old_flame(x, maxy - y).r = new_flame(x, maxy - y).r  'old_flame=new_flame
          old_flame(x, maxy - y).g = new_flame(x, maxy - y).g
          old_flame(x, maxy - y).b = new_flame(x, maxy - y).b
          old_flame(x, maxy - y).c = new_flame(x, maxy - y).c
     Next y
  Next x
  Label1.Visible = False
  Timer1.Enabled = True   ' Call the Fire brigade :)
  Timer2.Enabled = False  ' Turn off the taps!
End Sub