发个下雪的代码!
发一个下雪代码 Option Explicit
'in form1 add timer
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 GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y 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 RedrawWindow Lib "user32" (ByVal hWnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Const SNOW_MAX& = 100
Private Const FALL_SPEED& = 3
Private Const COLOR_DIFF = 100
Dim ScreenDC&, ScreenW&, ScreenH&
Dim Snow&(SNOW_MAX, 1), Last&(SNOW_MAX)
Dim mlFrmWidth As Long
Dim mlFrmHeight As Long
Dim lbExit As Boolean
Private Sub Form_Click()
lbExit = True
End Sub
Private Sub Form_Load()
' Dim CER As Long
' CER = CreateEllipticRgn(35, 10, 300, 200)
' Call SetWindowRgn(Me.hWnd, CER, True)
mlFrmWidth = Width
mlFrmHeight = Height
lbExit = False
Timer1.Interval = 100
Timer1.Enabled = True
End Sub
Private Sub NewSnow(i&)
Snow(i, 0) = Rnd * ScreenW
Snow(i, 1) = 0
Last(i) = GetPixel(ScreenDC, Snow(i, 0), 0)
End Sub
Private Function ColorDec(Color1&, Color2&) As Long
Dim R1%, G1%, B1%
Dim R2%, G2%, B2%
GetRGB Color1, R1, G1, B1
GetRGB Color2, R2, G2, B2
ColorDec = Abs(R1 - R2) + Abs(G1 - G2) + Abs(B1 - B2)
End Function
Private Sub GetRGB(ByVal Color&, ByRef r%, ByRef g%, ByRef b%)
r = (Color Mod 256)
b = (Int(Color \ 65536))
g = ((Color - (b * 65536) - r) \ 256)
End Sub
Private Sub Form_Resize()
If WindowState <> 1 Then
Width = mlFrmWidth
Height = mlFrmHeight
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
lbExit = True
Erase Snow
Erase Last
RedrawWindow ScreenDC, ByVal 0, ByVal 0, &H1
Set Form1 = Nothing
End Sub
Private Sub Timer1_Timer()
Dim llCount As Long
Timer1.Enabled = False
Dim i As Long, k As Long
Dim lPic As Long
Dim llColor As Long
ScreenDC = GetWindowDC(0)
ScreenW = Screen.Width / Screen.TwipsPerPixelX
ScreenH = Screen.Height / Screen.TwipsPerPixelY
Randomize
For i = 0 To SNOW_MAX
NewSnow i
Next
On Error Resume Next
Do
' If llCount Mod 20 = 0 Then
' llColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
' Label1.ForeColor = llColor
' Label2.ForeColor = llColor
' Label3.ForeColor = llColor
' End If
' llCount = llCount + 1
For lPic = 0 To 7
For i = 0 To SNOW_MAX
SetPixel ScreenDC, Snow(i, 0) + 1, Snow(i, 1) + 1, Last(i)
SetPixel ScreenDC, Snow(i, 0) + 1, Snow(i, 1), Last(i)
SetPixel ScreenDC, Snow(i, 0), Snow(i, 1) + 1, Last(i)
SetPixel ScreenDC, Snow(i, 0) - 1, Snow(i, 1) + 1, Last(i)
SetPixel ScreenDC, Snow(i, 0) + 1, Snow(i, 1) + 1, Last(i)
SetPixel ScreenDC, Snow(i, 0), Snow(i, 1), Last(i)
SetPixel ScreenDC, Snow(i, 0) - 1, Snow(i, 1) - 1, Last(i)
SetPixel ScreenDC, Snow(i, 0) - 1, Snow(i, 1), Last(i)
SetPixel ScreenDC, Snow(i, 0), Snow(i, 1) - 1, Last(i)
Snow(i, 0) = Snow(i, 0) + Rnd * FALL_SPEED - FALL_SPEED / 2 '左右随机偏转
Snow(i, 1) = Snow(i, 1) + Rnd * FALL_SPEED '下落
If Snow(i, 0) < 0 Or Snow(i, 0) > ScreenW Or Snow(i, 1) > ScreenH Then
NewSnow i
Else
k = Last(i)
Last(i) = GetPixel(ScreenDC, Snow(i, 0), Snow(i, 1))
SetPixel ScreenDC, Snow(i, 0) + 1, Snow(i, 1) + 1, vbWhite
SetPixel ScreenDC, Snow(i, 0) + 1, Snow(i, 1), vbWhite
SetPixel ScreenDC, Snow(i, 0), Snow(i, 1) + 1, vbWhite
SetPixel ScreenDC, Snow(i, 0) - 1, Snow(i, 1) + 1, vbWhite
SetPixel ScreenDC, Snow(i, 0) + 1, Snow(i, 1) + 1, vbWhite
SetPixel ScreenDC, Snow(i, 0), Snow(i, 1), vbWhite
SetPixel ScreenDC, Snow(i, 0) - 1, Snow(i, 1) - 1, vbWhite
SetPixel ScreenDC, Snow(i, 0) - 1, Snow(i, 1), vbWhite
If Rnd * 3 < 1 And ColorDec(k, Last(i)) > COLOR_DIFF Then NewSnow i
End If
Next
If lbExit = True Then Exit Do
Sleep 20
DoEvents
Picture = Picture1(lPic).Picture
Next
Loop
Unload Me
End Sub
下雪.rar
(300.15 KB)
