Option Explicit
'Lock the specified window, preventing it from updating. Only one window can be locked at a time, which can be used when the layout of the interface is changed in a large arc.
Private Declare Function LockWindowUpdate Lib “user32” (ByVal hwndLock As Long) As Long
'Set the RGB value of a pixel in the specified device scene
Private Declare Function SetPixelV Lib “gdi32” (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Byte
'Copy a bitmap from one device context to another. The source and destination DC must be compatible with each other
Private Declare Function BitBlt Lib “gdi32” (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Dim FX, FY As Integer
Dim EndingFlag As Boolean
Dim Frame As Integer
Dim ProcDem As Byte
Dim X As Integer
Dim Y As Integer
Dim FlameArray() As Byte
Dim Temp2 As Byte
Dim Uniformity As Byte
Dim Test As Byte
Dim Temp As Single
Dim Color As Integer
Dim FillVal As Byte
Dim WithEvents FadeAction As PictureBox
Dim WithEvents Go As CommandButton
Private Sub RunMain()
Do While Not EndingFlag = False
Frame = Frame + 1
If Frame Mod ProcDem = 0 Then DoEvents
For Y = FY To 4 Step -1
For X = 0 To FX Step 1
Temp2 = FlameArray(X, Y)
If Temp2 < Uniformity - 1 Then GoTo 1
Test = Int(Rnd * Uniformity)
FlameArray(X, Y) = Temp2 - Test
FlameArray(X, Y - Test) = FlameArray(X, Y)
Color = FlameArray(X, Y) * Temp
SetPixelV FadeAction.hdc, X + (Rnd * 2), Y, RGB(Color + Color, Color, Color / 2)
1 Next X
Next Y
For X = 0 To FX
For Y = FillVal To FY
FlameArray(X, Y) = FY
Next Y
Next X
Me.Cls
BitBlt Me.hdc, (Me.ScaleWidth - FX) / 2, (Me.ScaleHeight - FY) / 2, FX, FY, FadeAction.hdc, 0, 0, vbSrcCopy
Loop
End Sub
Private Sub go_Click()
With Go
If Go.Caption = “开始” Then
.Caption = “暂停”
EndingFlag = True
RunMain
Else
Go.Caption = “开始”
EndingFlag = False
End If
End With
End Sub
Private Sub Form_Load()
Me.ScaleMode = vbPixels
Me.BackColor = vbBlack
Me.Caption = “VB实现火焰的效果”
FX = 420
FY = 32
Set FadeAction = Me.Controls.Add(“VB.PictureBox”, “FadeAction”)
With FadeAction
.AutoRedraw = True
.ScaleMode = vbPixels
.BackColor = vbBlack
.Width = FX * Screen.TwipsPerPixelX + 4
.Height = FY * Screen.TwipsPerPixelY + 4
End With
Set Go = Me.Controls.Add(“VB.CommandButton”, “Go”)
With Go
Go.Caption = “开始”
Go.Width = 80
Go.Height = 25
.Visible = True
End With
ReDim FlameArray(0 To FX, 0 To FY) As Byte
Uniformity = 2
ProcDem = 1
LockWindowUpdate FadeAction.hWnd
Temp = 256 / FY
FillVal = FY * 0.9
End Sub