📄 formsnow.frm
字号:
VERSION 5.00
Begin VB.Form FormSnow
AutoRedraw = -1 'True
BackColor = &H00800000&
Caption = "雪花飞舞"
ClientHeight = 6750
ClientLeft = 60
ClientTop = 345
ClientWidth = 6135
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C0C0C0&
Icon = "FormSnow.frx":0000
LinkTopic = "Form1"
ScaleHeight = 450
ScaleMode = 3 'Pixel
ScaleWidth = 409
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton cmdStop
Caption = "停止"
Height = 375
Left = 4320
TabIndex = 14
Top = 6120
Width = 1095
End
Begin VB.TextBox TextNParticle
Height = 285
Left = 3960
MaxLength = 4
TabIndex = 11
Text = "250"
Top = 5625
Width = 615
End
Begin VB.HScrollBar HScroll1
Height = 255
Index = 0
LargeChange = 20
Left = 1020
Max = 100
Min = 1
SmallChange = 2
TabIndex = 9
TabStop = 0 'False
Top = 5640
Value = 10
Width = 1755
End
Begin VB.HScrollBar HScroll1
Height = 255
Index = 2
LargeChange = 4
Left = 1020
Max = 10
Min = -10
TabIndex = 8
TabStop = 0 'False
Top = 5190
Value = 3
Width = 1755
End
Begin VB.HScrollBar HScroll1
Height = 255
Index = 1
LargeChange = 4
Left = 1020
Max = 10
Min = -10
TabIndex = 7
TabStop = 0 'False
Top = 4740
Value = 2
Width = 1755
End
Begin VB.OptionButton Option1
BackColor = &H00800000&
Caption = "窗体"
ForeColor = &H00C0C0C0&
Height = 255
Index = 1
Left = 4560
TabIndex = 3
TabStop = 0 'False
Top = 5190
Width = 795
End
Begin VB.OptionButton Option1
BackColor = &H00800000&
Caption = "图片框"
ForeColor = &H00C0C0C0&
Height = 255
Index = 0
Left = 3180
TabIndex = 2
TabStop = 0 'False
Top = 5190
Value = -1 'True
Width = 1155
End
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 30
Left = 960
Top = 6120
End
Begin VB.CommandButton CommandFallSnow
BackColor = &H00800000&
Caption = "开始"
Default = -1 'True
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 178
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 2760
TabIndex = 1
Top = 6120
Width = 1095
End
Begin VB.PictureBox Picture1
Appearance = 0 'Flat
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H80000005&
BorderStyle = 0 'None
FillColor = &H00FFFFFF&
BeginProperty Font
Name = "Arial"
Size = 8.25
Charset = 178
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 3945
Left = 480
Picture = "FormSnow.frx":0442
ScaleHeight = 263
ScaleMode = 3 'Pixel
ScaleWidth = 350
TabIndex = 0
Top = 420
Width = 5250
End
Begin VB.TextBox TextBorder
BackColor = &H00C0C0C0&
Height = 4020
Left = 435
Locked = -1 'True
TabIndex = 13
Top = 375
Width = 5325
End
Begin VB.Label Label4
AutoSize = -1 'True
BackColor = &H00800000&
Caption = "下落速度"
ForeColor = &H00C0C0C0&
Height = 195
Left = 240
TabIndex = 12
Top = 5670
Width = 720
End
Begin VB.Label Label3
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "雪花位置："
ForeColor = &H00C0C0C0&
Height = 195
Left = 3120
TabIndex = 10
Top = 4800
Width = 900
End
Begin VB.Label Label1
AutoSize = -1 'True
BackColor = &H00800000&
Caption = "下落"
ForeColor = &H00C0C0C0&
Height = 195
Index = 2
Left = 600
TabIndex = 6
Top = 5220
Width = 360
End
Begin VB.Label Label1
AutoSize = -1 'True
BackColor = &H00800000&
Caption = "风向"
ForeColor = &H00C0C0C0&
Height = 195
Index = 1
Left = 600
TabIndex = 5
Top = 4770
Width = 360
End
Begin VB.Label Label1
AutoSize = -1 'True
BackColor = &H00800000&
Caption = "雪花数量"
ForeColor = &H00C0C0C0&
Height = 195
Index = 0
Left = 3120
TabIndex = 4
Top = 5670
Width = 720
End
End
Attribute VB_Name = "FormSnow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
DefLng A-Z
Option Explicit
'声明API函数:
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc, ByVal x, ByVal y) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, _
ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, _
ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal Hwnd As Long, ByVal hdc As Long) As Long
Dim nSnow As Long
Dim VxMinSnow As Single, VxMaxSnow As Single, VyMinSnow As Single, VyMaxSnow As Single
Dim VxAddMin As Single, VxAddMax As Single, VyAddMin As Single, VyAddMax As Single
Dim WidthWindowSnow, HeightWindowSnow
'xSnow保存雪花的X坐标，ySnow保存雪花的y坐标
Dim xSnow() As Single, ySnow() As Single, VxSnow() As Single, VySnow() As Single
Dim ColPrevSnow(), ColSnow() As Long 'ColSnow()保存颜色
Dim hdcSnow As Long, HwndSnow As Long
Dim StopSnow As Integer, DontClearParticles As Boolean
Dim IsInAnimateSnow As Boolean, IsInCmdFall As Boolean
Private Sub cmdStop_Click()
Timer1.Enabled = False
ClearSnowParticles
StopSnow = True
End Sub
Private Sub CommandFallSnow_Click()
If IsInCmdFall Then Exit Sub
IsInCmdFall = True
Timer1.Enabled = False
StopSnow = False
ClearSnowParticles
DontClearParticles = False
nSnow = Val(TextNParticle.Text) '雪花数量
If nSnow < 0 Then nSnow = 250
Dim i
SetInitialSnowPositions '初始化雪花
For i = 1 To 50
AnimateSnow False
DoEvents
Next
If -1 = True Then
For i = 1 To nSnow
ySnow(i) = ySnow(i) - (HeightWindowSnow + 1) * Sgn(VySnow(i))
Next
End If
AnimateSnow
Timer1.Enabled = True
IsInCmdFall = False
End Sub
Sub SetInitialSnowPositions(Optional DrawInitialParticles As Boolean = False)
'初始化雪花的位置
ReDim xSnow(nSnow), ySnow(nSnow), VxSnow(nSnow), VySnow(nSnow), ColPrevSnow(nSnow), ColSnow(nSnow)
Dim w, h, hdc, i, x, y, c
hdc = hdcSnow
w = WidthWindowSnow
h = HeightWindowSnow
'随机确定雪花的 x,y 坐标
For i = 1 To nSnow
x = Rnd * w: y = Rnd * h
xSnow(i) = x: ySnow(i) = y
If Rnd < 0.3 Then
c = &HFFFFFF
Else
c = 150 + Rnd * (260 - 150)
If c > 255 Then c = 255
c = GetRealNearestColor(hdc, RGB(c, c, c))
End If
ColSnow(i) = c
ColPrevSnow(i) = GetPixel(hdc, x, y) '原来的点
VxSnow(i) = VxMinSnow + Rnd * (VxMaxSnow - VxMinSnow) '下一位置
VySnow(i) = VyMinSnow + Rnd * (VyMaxSnow - VyMinSnow)
If DrawInitialParticles Then SetPixelV hdc, x, y, c
Next
End Sub
Sub SetSpeed()
'设置雪花移动的速度
Dim vx As Single, vy As Single, r As Single
VxAddMin = -0.1
VxAddMax = 0.1
VyAddMin = -0.1
VyAddMax = 0.1
vx = HScroll1(1).Value / 2
vy = HScroll1(2).Value / 2
VxMinSnow = vx - 3
VxMaxSnow = vx + 3
VyMinSnow = vy - 3
VyMaxSnow = vy + 3
End Sub
Sub AnimateSnow(Optional DrawParticles As Boolean = -1)
If IsInAnimateSnow Then Exit Sub
IsInAnimateSnow = True
Dim w, h, hdc, i, x As Single, y As Single, vx As Single, vy As Single, c
Dim j, jx, c2
hdc = hdcSnow
w = WidthWindowSnow
h = HeightWindowSnow
If DrawParticles Then '清除原来的雪花点
For i = nSnow To 1 Step -1
c = ColPrevSnow(i) '装入原来点的颜色
If c <> -1 Then SetPixelV hdc, xSnow(i), ySnow(i), c
Next
End If
For i = 1 To nSnow
x = xSnow(i)
y = ySnow(i)
vx = VxSnow(i) + VxAddMin + Rnd * (VxAddMax - VxAddMin)
vy = VySnow(i) + VyAddMin + Rnd * (VyAddMax - VyAddMin)
SetValueInRange vx, VxMinSnow, VxMaxSnow
SetValueInRange vy, VyMinSnow, VyMaxSnow
VxSnow(i) = vx ' 下一位置
VySnow(i) = vy
x = x + vx
y = y + vy
If Not StopSnow Then
'判断雪点的位置是否超出边界
If y > h And vy >= 0 Then
y = 0
Else
If y < 0 And vy <= 0 Then y = h
End If
End If
SetValueInRange x, 0, w, True
c = GetPixel(hdc, x, y) '取得下一点原来的颜色
xSnow(i) = x
ySnow(i) = y
ColPrevSnow(i) = c
If DrawParticles And c <> -1 Then
SetPixelV hdc, x, y, ColSnow(i) '画上雪花点
End If
Next
IsInAnimateSnow = False
End Sub
Sub ClearSnowParticles()
'清除当前的雪花粒
Dim hdc, i, c
If DontClearParticles Then Exit Sub
hdc = hdcSnow
For i = nSnow To 1 Step -1
c = ColPrevSnow(i)
If c <> -1 Then SetPixelV hdc, xSnow(i), ySnow(i), c
Next
End Sub
Sub SetValueInRange(v As Variant, ByVal RangeMin As Variant, ByVal RangeMax As Variant, _
Optional SwapMaxMin As Boolean = False)
If SwapMaxMin Then
If v < RangeMin Then v = RangeMax Else If v > RangeMax Then v = RangeMin
Else
If v < RangeMin Then v = RangeMin Else If v > RangeMax Then v = RangeMax
End If
End Sub
Private Sub Form_Load()
Picture1.ScaleMode = vbPixels
Me.Show: DoEvents
Call SetSpeed
Option1_Click (0)
End Sub
Function GetRealNearestColor(ByVal hdc1 As Long, ByVal Col As Long) As Long
Dim c As Long
c = GetPixel(hdc1, 1, 1)
If c <> -1 Then
GetRealNearestColor = SetPixel(hdc1, 1, 1, Col)
SetPixelV hdc1, 1, 1, c
Else
GetRealNearestColor = Col 'faild to test
End If
End Function
Private Sub HScroll1_Change(Index As Integer)
If Index = 0 Then '定时器控制下落速度
Timer1.Interval = HScroll1(0).Value
Else '风向,方向或随机值
Call SetSpeed
End If
End Sub
Private Sub HScroll1_Scroll(Index As Integer)
HScroll1_Change Index
End Sub
Private Sub Option1_Click(Index As Integer)
If Option1(Index).Value = 0 Then Option1(Index).Value = 1
Dim obj(2) As Object, Cobj As Object
Set obj(1) = Picture1
Set obj(2) = Me
DeleteUsedSnowDC
DontClearParticles = True
Set Cobj = obj(Index + 1)
With Cobj
WidthWindowSnow = .ScaleWidth - 1
HeightWindowSnow = .ScaleHeight - 1
HwndSnow = .Hwnd '取得对象的句柄
End With
hdcSnow = GetDC(HwndSnow)
If Timer1.Enabled Then CommandFallSnow_Click
End Sub
Private Sub TextNParticle_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then KeyAscii = 0: CommandFallSnow_Click
End Sub
Private Sub Timer1_Timer()
AnimateSnow
End Sub
Private Sub Form_Unload(Cancel As Integer)
DeleteUsedSnowDC
End Sub
Sub DeleteUsedSnowDC()
If hdcSnow <> 0 Then
ClearSnowParticles
ReleaseDC HwndSnow, hdcSnow
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -