vb写一段下雪花的代码怎么做？

Dim Snow(1000, 2), Amounty As Integer

Private Sub Form_Load()

Form1.Show

DoEvents

Randomize

Amounty = 325

For J = 1 To Amounty

Snow(J, 0) = Int(Rnd * Form1.Width)

Snow(J, 1) = Int(Rnd * Form1.Height)

Snow(J, 2) = 10 + (Rnd * 20)

Next J

Do While Not (DoEvents = 0)

For LS = 1 To 10

For I = 1 To Amounty

OldX = Snow(I, 0): OldY = Snow(I, 1)

Snow(I, 1) = Snow(I, 1) + Snow(I, 2)

If Snow(I, 1) > Form1.Height Then

Snow(I, 1) = 0: Snow(I, 2) = 5 + (Rnd * 30)

Snow(I, 0) = Int(Rnd * Form1.Width)

OldX = 0: OldY = 0

End If

Coloury = 8 * (Snow(I, 2) - 10): Coloury =60 + Coloury

PSet (OldX, OldY), QBColor(0)

PSet (Snow(I, 0), Snow(I, 1)), RGB(Coloury,Coloury, Coloury)

Next I

Next LS

Loop

End

EndSub

vb做的飘雪桌面

在窗体中加两个timer

代码如下：

'虫虫青摘自己互联网

Option Explicit

'源代码

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()

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 Timer1_Timer()

DrawP '画出一帧

End Sub

Private Sub Timer2_Timer()

'改变风向

Vx = Rnd() * 4 - 2

Vy = Rnd() + 2

End Sub

'完，最后，需要两个Timer：Timer1、Timer2。

DefLng A-Z 'define Long type as default declaration of variables.

Option Explicit

'API Declaretions:

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

'-- Device Context functions

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

'dwRop in BitBlt (and StretchBlt):

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

'Custom Declarations:

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

Dim xSnow() As Single, ySnow() As Single, VxSnow() As Single, VySnow() As Single

Dim ColPrevSnow(), ColSnow() As Long

Dim hdcSnow As Long, HwndSnow As Long

Dim StopSnow As Integer, DontClearParticles As Boolean

Dim IsInAnimateSnow As Boolean, IsInCmdFall As Boolean

Private Sub CommandFallSnow_Click()

If IsInCmdFall Then Exit Sub

IsInCmdFall = True

Timer1.Enabled = False

StopSnow = False

ClearSnowParticles

DontClearParticles = False 'the value True means that don't clear particles in 'ClearSnowParticles' sub

nSnow = Val(TextNParticle.Text)

If nSnow <0 Then nSnow = 250

Dim i

SetInitialSnowPositions

'this loop is to reach to steady state motion!

For i = 1 To 50

AnimateSnow False

DoEvents

Next

If -1 = True Then

'this loop cause to see begin of falling and particles do not appear instantly

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

'set a x,y position , velocity(x,y) and a color for each particle:

For i = 1 To nSnow

x = Rnd * w: y = Rnd * h

xSnow(i) = x: ySnow(i) = y

If Rnd <0.3 Then

c = &HFFFFFF ' &HFFEFEF

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

'Vx,yMin,MaxSnow: determine Min,Max value of absolute speed

'VxMinSnow = -1.5: VxMaxSnow = 1.5

'VyMinSnow = -1: VyMaxSnow = 2

'Vx,yAddMin,Max: determine Min,Max of rate of change in speed (i.e. acceleration)

VxAddMin = -0.1: VxAddMax = 0.1

VyAddMin = -0.1: VyAddMax = 0.1

vx = HScroll1(1).Value / 2: vy = HScroll1(2).Value / 2

r = HScroll1(3).Value / 4

VxMinSnow = vx - r / 2: VxMaxSnow = vx + r / 2

VyMinSnow = vy - r / 2: VyMaxSnow = vy + r / 2

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 'clear old pixels:

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

'SetValueInRange y, 0, h, True

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) 'return (-1) if x,y be out of real part of window

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()

'clear current particles

Dim hdc, i, c

If DontClearParticles Then Exit Sub 'particles are cleared before and must be clear again (because hdc may be changed!)

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 '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

Private Sub CommandLoadPic_Click()

On Error Resume Next

CD1.ShowOpen

If Err Then Err.Clear: Exit Sub

ClearSnowParticles

DontClearParticles = True

Dim w, h

With PictureTmp

.Picture = LoadPicture(CD1.FileName)

w = Picture1.ScaleWidth: h = Picture1.ScaleHeight

Picture1.PaintPicture .Picture, 0, 0, w, h, 0, 0, .ScaleWidth, .ScaleHeight

End With

Option1_Click (0)

CommandFallSnow_Click

End Sub

Private Sub CommandStopSnow_Click()

StopSnow = True

End Sub

Private Sub Form_Load()

Picture1.ScaleMode = vbPixels

Me.Show: DoEvents

Call SetSpeed

'ColSnow = &HFFFFFF

'ColSnow(i) = GetRealNearestColor(hdc, ColSnow(i))

Option1_Click (0)

CommandFallSnow_Click

End Sub

Function GetRealNearestColor(ByVal hdc1 As Long, ByVal Col As Long) As Long

Dim c As Long

'to get real color (using getnearestcolor function may have some problems!

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 'timer

Timer1.Interval = HScroll1(0).Value

Else 'wind,weight or random

Call SetSpeed

End If

End Sub

Private Sub HScroll1_Scroll(Index As Integer)

HScroll1_Change Index

End Sub

Private Sub Label5_Click()

MsgBox "炎炎夏日,我好回忆去年冬天的那场大雪!:)" + vbCrLf + vbCrLf + "mnd@" + Chr(77) + "ndsoft" + ".c" + Chr(111) + "m" + vbCrLf + "尚网www.0731up.com" + Space(20) + vbCrLf, , "关于..."

End Sub

Private Sub Option1_Click(Index As Integer)

If Option1(Index).Value = 0 Then Option1(Index).Value = 1

Dim obj(3) As Object, Cobj As Object

Set obj(1) = Picture1: Set obj(2) = Dir1: Set obj(3) = Me

DeleteUsedSnowDC

DontClearParticles = True

If Index <>1 And Dir1.Enabled = False Then Dir1.Enabled = True

Set Cobj = obj(Index + 1)

With Cobj

If Index = 1 Then

.Enabled = False

Else

WidthWindowSnow = .ScaleWidth - 1: HeightWindowSnow = .ScaleHeight - 1

End If

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

还需要添加一些控件，如果想要源工程的话，我发给你:qingqingdao5566@126.com

---