Option Explicit
DefLng A-Z 'define Long type as default declaration of variables.
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal sΖFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long '-下载文件
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 GetNearestColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal x1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
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
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Const SRCPAINT = &HEE0086        'dest = source OR dest
Private Const SRCERASE = &H440328        'dest = source AND (NOT dest )
Private Const SRCAND = &H8800C6          'dest = source AND dest
Private Const SRCCOPY = &HCC0020         'dest = source


Private Const SRCINVERT = &H660046       'dest = source XOR dest
Dim xx1() As Single, yy1() As Single
Dim Vxx1() As Single, Vyy1() As Single
Dim oldcolor() As Long
Dim StopSnow As Boolean, clearpic As Boolean
Dim VxMisnowpcs!, VxMaxx1!, VyMisnowpcs!, VyMaxx1!
Dim VxAddMin!, VxAddMax!, VyAddMin!, VyAddMax!
Dim hdcSnow&, HwndSnow&, snowpcs&, colorno&, songname$
Dim W%, H%, i%, j%, twid%, thigh%, playyn As Boolean
Dim vx!, vy!, X!, Y!, r!, jx
Private WithEvents Timer1 As Timer
Private WithEvents Timer2 As Timer
Private WithEvents Label1 As Label
Private WithEvents Label2 As Label
Private Sub Form_Load()
        Set Timer1 = Controls.Add("vb.timer", "timer1")
        Set Timer2 = Controls.Add("vb.timer", "timer2")
        Timer1.Interval = 10
        Timer2.Interval = 500
        Set Label1 = Controls.Add("vb.label", "Label1")
        Set Label2 = Controls.Add("vb.label", "Label2")
        Me.WindowState = 2
        Me.BackColor = QBColor(0)
        Me.BorderStyle = 0: Me.Caption = "": Me.ScaleMode = 3
        Me.Width = Screen.Width: Me.Height = Screen.Height: Me.Move 0, 0
        Me.Show: DoEvents
        Label1.Visible = True
        Label1.Caption = "←雪往左飘, →雪往右飘, ↑雪往上飘, ↓雪往下飘,Home 风大了,End 风小了,鼠标右键雪停了或再下雪"
        Label1.AutoSize = True
        Label1.BackStyle = 0
        Label1.Font = "楷体_GB2312"
        Label1.FontSize = 16
        Label1.ForeColor = QBColor(10)
        Label1.Move 5, 20 '(Me.Width - Label1.Width) \ 15 \ 2, 20
   
        Label2.Visible = True
        Label2.Caption = "游 子 吟"
        Label2.AutoSize = True
        Label2.BackStyle = 0
        Label2.Font = "楷体_GB2312"
        Label2.FontSize = 48
        Label2.ForeColor = QBColor(10)
        Label2.Move (Me.Width - Label2.Width * 15) \ 2 \ 15, (Me.Height - Label2.Height * 15) \ 2 \ 15
        snowpcs = 800
        twid = Me.ScaleWidth - 1:       thigh = Me.ScaleHeight - 1


        Call SetSpeed '设定速度
        HwndSnow = Me.hwnd
        hdcSnow = GetDC(HwndSnow)
        Call startsnow '开始下雪
        Me.KeyPreview = True
End Sub
Private Sub Form_Activate()
        songname = "c:\traveler.mp3"
        If Dir(songname) = "" Then
        Timer2.Enabled = True
        End If
End Sub
'timer1.interval=1--100,vx= -5--+5 , vy=-5--+5, r=0--5
Sub SetSpeed()
        VxAddMin = -0.1: VxAddMax = 0.1
        VyAddMin = -0.1: VyAddMax = 0.1
        vx = 2       'HScroll1(1).Value / 2
        vy = 2       'HScroll1(2).Value / 2
        r = 2.5 'HScroll1(3).Value / 4
        VxMisnowpcs = vx - r / 2: VxMaxx1 = vx + r / 2
        VyMisnowpcs = vy - r / 2: VyMaxx1 = vy + r / 2
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
        If Button = 1 Then '左键退出,右键停止下雪
           Unload Me
        Else '2
           If StopSnow = False Then Call startsnow
           StopSnow = Not StopSnow
        End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
        DeleteUsedSnowDC
        mciSendString "stop " & songname, vbNullString, 0, 0
        mciSendString "close " & songname, vbNullString, 0, 0
        End
End Sub
Sub DeleteUsedSnowDC()
        If hdcSnow <> 0 Then
           ClearSnowParticles
           ReleaseDC HwndSnow, hdcSnow
        End If
End Sub
Sub InitPos()
        ReDim xx1(snowpcs), yy1(snowpcs), Vxx1(snowpcs), Vyy1(snowpcs), oldcolor(snowpcs)
        Dim hdc
        hdc = hdcSnow
        W = twid: H = thigh
        For i = 1 To snowpcs


           xx1(i) = Rnd * W: yy1(i) = Rnd * H
           colorno = &HFFFFFF ' &HFFEFEF
           oldcolor(i) = GetPixel(hdc, xx1(i), yy1(i))
           Vxx1(i) = VxMisnowpcs + Rnd * (VxMaxx1 - VxMisnowpcs)
           Vyy1(i) = VyMisnowpcs + Rnd * (VyMaxx1 - VyMisnowpcs)
        Next
End Sub
Private Sub Timer1_Timer()
        AnimateSnow
End Sub
Private Sub startsnow()
        Timer1.Enabled = False
        StopSnow = False
        ClearSnowParticles
        clearpic = True
        If snowpcs < 0 Then snowpcs = 250
        InitPos
        'this loop is to reach to steady state motion!
        For i = 1 To 50
           AnimateSnow 'False
           DoEvents
        Next
        AnimateSnow
        Timer1.Enabled = True
End Sub
Sub SetValueInRange(v As Variant, ByVal RangeMin As Variant, ByVal RangeMax As Variant, Optional SwapMaxMin As Boolean = False)
        If SwapMaxMin Then 'swapMaxMin=True:
           If v < RangeMin Then v = RangeMax Else If v > RangeMax Then v = RangeMin
        Else 'default (swapmaxmin=false)
           If v < RangeMin Then v = RangeMin Else If v > RangeMax Then v = RangeMax
        End If
End Sub
Sub AnimateSnow()
        Dim hdc
        hdc = hdcSnow
        W = twid: H = thigh
        For i = snowpcs To 1 Step -1
           colorno = oldcolor(i)
           If colorno <> -1 Then SetPixelV hdc, xx1(i), yy1(i), colorno
        Next
        For i = 1 To snowpcs
           X = xx1(i): Y = yy1(i)
           vx = Vxx1(i) + VxAddMin + Rnd * (VxAddMax - VxAddMin)


看天书~