Option Explicit
‘锁定指定窗口，禁止它更新。同一时刻间只能有一个窗口处于锁定状态，可用在界面作大弧度布局改变时。
Private Declare Function LockWindowUpdate Lib “user32” (ByVal hwndLock As Long) As Long
‘在指定的设备场景中设置一个像素的RGB值
Private Declare Function SetPixelV Lib “gdi32” (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Byte
‘将一幅位图从一个设备场景复制到另一个。源和目标DC相互间必须兼容
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