基于VB算法+Picture+Timer控件制作的39种动画效果,类似屏保（完整原程序）

动画播放器程序，在WIN2003调试通过，详细请自行下载进行学习测试，程序大小13K

下载地址:http://www.lshdic.com/download/lshdic/vb_xiaoguo.rar

代码浏览：

Dim xiaoguo As Integer ´选择产生的效果

Dim wid As Long ´显示器的宽

Dim hei As Long ´显示器的高

Dim pos1 As Long ´产生效果所必须的记数游标

Dim coloris As Integer ´由用户选择的颜色效果,0=随机任意色,1=随机渐变色

Dim colorstart(2) As Integer ´当选择随机渐变色时,该数组为了实现随机色彩的记录

Dim heibai As Boolean ´黑白对比色时,决定是否走向黑的或白的一面

Dim heibaicolor As Integer ´范围0-255,为了记录黑白对比色,黑白渐淡色,黑百渐浓色的灰度

Dim lihe As Boolean ´为完成天地之吻,沉睡之心做出离合判断

Dim pos2 As Long ´为完成地狱之火做出持续的喷放效果

Dim xx() As Long ´为完成生命繁衍，计算球体向右的移动量

Dim yy() As Long ´为完成生命繁衍，计算球体向下的移动量

Dim jiaX() As Boolean ´为完成生命繁衍，计算是否增加或减少XX

Dim jiaY() As Boolean ´为完成生命繁衍，计算是否增加或减少YY

Dim rectmax As Integer ´为完成“数据阵列”，计算X，Y的最大阵列

Dim hang As Integer ´为完成“现代言论”，计算到了第几行了

Dim pos3 As Long ´为完成“旋转光线”，计算第二条线的移动偏差

Dim bcolor As String ´为历史记录保存画布的背景颜色

Private Sub Command1_Click(Index As Integer) ´39个按钮接收到单击事件时（初始化效果）

p.Cls: p.CurrentX = 0: p.CurrentY = 0: pos1 = 0: pos2 = 0: p.FillColor = bcolor

p.FontSize = 9: p.FontBold = False: p.BackColor = bcolor: lihe = False

p.FillStyle = 1: pos3 = 0 ´上三行初始化播放器

Select Case Index

Case 5: p.DrawWidth = 10 ´DrawWidth定义线段的粗度

Case 7: p.DrawWidth = 8

Case 8: p.DrawWidth = 9

Case 9: p.DrawWidth = 3

Case 10: p.DrawWidth = 3

Case 11: p.DrawWidth = 3

Case 12: p.DrawWidth = 3

Case 13: p.DrawWidth = 3

Case 14: p.DrawWidth = 6

Case 15: p.DrawWidth = 3

Case 16: p.DrawWidth = 3

Case 17: p.DrawWidth = 3

Case 18: p.DrawWidth = 5

Case 19:

ReDim xx(5): ReDim yy(5): ReDim jiaX(5): ReDim jiaY(5) ´为实现多线程,初始化线程存储数组

For i = 0 To 4

Randomize

xx(i) = wid * Rnd: yy(i) = hei * Rnd

Next: p.DrawWidth = 1

Case 21: p.DrawWidth = 3

Case 22: rectmax = Round(Rnd * 50): p.DrawWidth = 1

Case 23: p.FontSize = 12: p.FontBold = True: hang = 1

Case 26: p.FontSize = 12: p.FontBold = True

Case 27

ReDim xx(5): ReDim yy(5): ReDim jiaX(5): ReDim jiaY(5)

For i = 0 To 4

Randomize

xx(i) = wid * Rnd: yy(i) = hei * Rnd

Next: p.DrawWidth = 1: p.BackColor = vbBlack

Case 29: p.DrawWidth = 50

Case 31: ReDim xx(5): ReDim yy(5): ReDim jiaX(5): ReDim jiaY(5)

xx(0) = wid * Rnd: yy(0) = hei * Rnd: p.DrawWidth = 1

Case 33: p.DrawWidth = 5

Case 34: p.DrawWidth = 1

Case 37: p.FillStyle = 0: p.DrawWidth = 2

Case Else

p.DrawWidth = 1

End Select

xiaoguo = Index: Timer1.Enabled = True ´开始运行播放器

End Sub

Private Sub Form_Load()

xiaoguo = 0: p.BackColor = vbWhite: bcolor = vbWhite

For i = 0 To 2: colorstart(i) = Round(Rnd * 255): Next ´启动时生成三个随机原色

End Sub

Private Sub Form_Resize() ´窗体移动时改变控件布局以及部分参数设置

On Error Resume Next

p.Width = Me.ScaleWidth - 200: Frame1.Top = Me.ScaleHeight - Frame1.Height - 100

p.Height = Frame1.Top - 100

If Me.ScaleWidth > Frame1.Width Then

Frame1.Left = Me.ScaleWidth / 2 - Frame1.Width / 2

End If

s.Top = p.Top + p.Height - s.Height

wid = p.Width: hei = p.Height

End Sub

Private Sub menu01_Click(Index As Integer) ´控制菜单中菜单列的单击

Select Case Index

Case 1: Timer1.Enabled = Not Timer1.Enabled ´播放/停止

Case 2: ´下一效果

If xiaoguo = Command1.Count - 1 Then xiaoguo = 0 Else xiaoguo = xiaoguo + 1

Command1_Click xiaoguo

Case 3: ´下一颜色系

For i = 0 To Option1.Count - 1

If Option1(i).Value = True Then Exit For

Next

If i = Option1.Count - 1 Then Option1(0).Value = True Else Option1(i + 1).Value = True

Case 4: ´设置背景

str1 = InputBox("请输入一个颜色代码,“&H蓝绿红”色系,原色参数00-ff之间", "背景设置", Hex(p.BackColor))

If str1 = "" Then Exit Sub

On Error Resume Next

oldcolor = p.BackColor: p.BackColor = "&h" & str1

If Err.Number 0 Then MsgBox "无效的背景颜色参数！", vbCritical, "错误参数": p.BackColor = oldcolor

bcolor = p.BackColor

Case 5: p.Cls ´清除画布

Case 6: s.Visible = Not s.Visible ´显示/隐藏速度控制

Case 8: ´保存画布图形为图片

If InStr(App.Path, "\") = Len(App.Path) Then path1 = App.Path Else path1 = App.Path & "\"

SavePicture p.Image, path1 & "效果图片" & xiaoguo & ".jpg"

path2 = "file:///" & Replace(path1 & "效果图片" & xiaoguo & ".jpg", "\", "/")

Shell "explorer " & path2, vbMaximizedFocus ´在WIN2003下无知为何不能正常在浏览器运行

End Select

End Sub

Private Sub p_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = 2 Then PopupMenu menu1 ´弹出菜单

End Sub

Private Sub s_Change() ´加快或减慢播放速度

Timer1.Interval = s.Value

End Sub

Private Sub Option1_Click(Index As Integer) ´颜色效果单选按钮数组的单击

coloris = Index

End Sub

Private Sub Timer1_Timer() ´播放循环计时器开始运行,以下39例效果算法未经我仔细检查,完全可以在次优化

Randomize

Select Case coloris

Case 0 ´应用随机任意色

color1 = RGB(Round(Rnd * 255), Round(Rnd * 255), Round(Rnd * 255))

Case 1 ´应用随机渐淡色

For i = 0 To 2

If colorstart(i) > 254 Then colorstart(i) = Round(Rnd * 255) Else colorstart(i) = colorstart(i) + 1

Next

color1 = RGB(colorstart(0), colorstart(1), colorstart(2))

Case 2 ´应用随机渐浓色

For i = 0 To 2

If colorstart(i) 254 Then heibai = True Else heibaicolor = heibaicolor + 1

Else

If heibaicolor 254 Then heibaicolor = Round(Rnd * 255) Else heibaicolor = heibaicolor + 1

color1 = RGB(heibaicolor, heibaicolor, heibaicolor)

Case 5 ´黑白渐浓色

If heibaicolor < 1 Then heibaicolor = Round(Rnd * 255) Else heibaicolor = heibaicolor - 1

color1 = RGB(heibaicolor, heibaicolor, heibaicolor)

End Select

Select Case xiaoguo

Case 0 ´横向线条

rnd1 = Round(Rnd * hei)

p.Line (0, rnd1)-(wid, rnd1), color1

Case 1 ´竖向线条

rnd1 = Round(Rnd * wid)

p.Line (rnd1, 0)-(rnd1, hei), color1

Case 2 ´右向辐射

p.Line (0, 0)-(Round(Rnd * wid), Round(Rnd * hei)), color1

Case 3 ´密集辐射

rnd1 = Round(Rnd * wid): rnd2 = Round(Rnd * hei)

p.Line (0, 0)-(rnd1, rnd2), color1

p.Line (0, hei)-(rnd1, rnd2), color1

p.Line (wid, 0)-(rnd1, rnd2), color1

p.Line (wid, hei)-(rnd1, rnd2), color1

Case 4 ´内部扩散

p.Line (wid / 2, hei / 2)-(wid * Rnd, hei * Rnd), color1

Case 5 ´左右扩展

If pos1 * 2 < wid Then pos1 = pos1 + 25 Else pos1 = 1

If pos1 Mod 2 0 Then ´如果是奇数则向右扩展,否则向左

p.Line (wid / 2 + pos1, 0)-(wid / 2 + pos1, hei), color1

Else

p.Line (wid / 2 - pos1, 0)-(wid / 2 - pos1, hei), color1

End If

Case 6 ´随机线段

rnd1 = wid * Rnd: rnd2 = hei * Rnd

rnd3 = Rnd * 1000: If rnd3 < 500 Then rnd3 = -rnd3

rnd4 = Rnd * 1000: If rnd4 < 500 Then rnd4 = -rnd4

For i = 0 To 3: p.Line (rnd1, rnd2)-(rnd1 + rnd3, rnd2 + rnd4), color1: Next

Case 7 ´随机颗粒

For i = 0 To 3: p.PSet (wid * Rnd, hei * Rnd), color1: Next

Case 8 ´虚拟葫芦

rnd1 = wid * Rnd: rnd2 = hei * Rnd

For i = 0 To 5

temp1 = 8 + (i * 3)

p.DrawWidth = temp1

p.PSet (rnd1 + (temp1 * 6 * i), rnd2 + (temp1 * 6 * i)), color1

Next

Case 9 ´三维十字

wid1 = wid / 2: hei1 = hei / 2

If pos1 * 2 < wid Then pos1 = pos1 + 7 Else pos1 = 1

If pos1 Mod 2 = 0 Then

p.Line (wid1 + pos1, 0)-(wid1 + pos1, hei), color1

p.Line (0, hei1 + pos1)-(wid, hei1 + pos1), color1

Else

p.Line (wid1 - pos1, 0)-(wid1 - pos1, hei), color1

p.Line (0, hei1 - pos1)-(wid, hei1 - pos1), color1

End If

Case 10 ´X型极光

If pos1 * 2 < wid Then pos1 = pos1 + 21 Else pos1 = 1

If pos1 Mod 2 = 0 Then

p.Line (0 + pos1, 0)-(wid + pos1, hei), color1

p.Line (wid + pos1, 0)-(0 + pos1, hei), color1

Else

p.Line (0 - pos1, 0)-(wid - pos1, hei), color1

p.Line (wid - pos1, 0)-(0 - pos1, hei), color1

End If

Case 11 ´金字魔塔

wid1 = wid / 2: hei1 = hei / 2

If pos1 * 3 hei Then lihe = False

If pos1 < 25 Then lihe = True

If lihe = False Then pos1 = pos1 - 20 Else pos1 = pos1 + 20

p.Line (0, 0 + pos1)-(wid, 0 + pos1), color1

p.Line (wid, hei - pos1)-(0, hei - pos1), color1

Case 13 ´堕落天使

If pos1 < hei Then pos1 = pos1 + 5 Else pos1 = 0

rnd1 = wid * Rnd

p.Line (rnd1, pos1)-(rnd1, pos1 + (500 * Rnd)), color1

p.Line (0, pos1 - 800)-(wid, pos1 - 800), p.BackColor

Case 14 ´地狱之火

If pos1 hei / 2 Then ´绘制火山

pos2 = pos1

Else

p.Line (wid1 - 800, hei)-(wid1, hei - 500), color1

p.Line -(wid1 + 800, hei), color1

End If

pos2 = pos2 + 1: p.PSet (wid1 + (pos2 * (Rnd - 0.5)), hei - 500 - (pos2 * (Rnd + 0.4))), color1

p.PSet (wid1 + (pos1 * (Rnd - 0.5)), hei - 500 - (pos1 * (Rnd + 0.4))), color1

Case 15 ´流金岁月

If pos1 > -hei Then pos1 = pos1 - 5 Else pos1 = 0

rnd1 = wid * Rnd: rnd2 = hei * Rnd

p.Line (rnd1, hei + pos1)-(rnd1, hei + pos1 - (Rnd * 500)), color1

p.Line (rnd1, rnd2)-(rnd1, rnd2 + (Rnd * 500)), p.BackColor

Case 16 ´光环之舞

If pos1 < 300 Then pos1 = pos1 + 15 Else pos1 = 0: If pos2 < 299 Then pos2 = 300

wid1 = wid / 2: hei1 = hei / 2

p.Line (pos1, pos1)-(wid - pos1, hei - pos1), color1, B

If pos2 hei Then pos2 = 0: pos1 = 0: p.Cls

p.Circle (wid1, hei1), pos2, color1, , , 1

End If

Case 17 ´成长衰亡

wid1 = wid / 2: hei1 = hei / 2

If pos1 > hei1 Then lihe = False

If pos1 < 10 Then lihe = True

If lihe = False Then

p.Circle (wid1, hei1), pos1, p.BackColor

pos1 = pos1 - 10

Else

pos1 = pos1 + 10

p.Circle (wid1, hei1), pos1, color1, , , Abs(Rnd + 0.5)

End If

Case 18 ´光之冲撞

wid1 = wid / 2: hei1 = hei / 2: rnd1 = Rnd * 200

If pos1 < wid Then pos1 = pos1 + 20 Else p.Cls: pos1 = 0: pos2 = 0

If rnd1 wid / 2 Then pos2 = pos2 + 20: p.Circle (wid1, hei1), pos2, color1, , , Rnd

Case 19 ´生命繁衍

p.Cls: pos1 = pos1 + 1

If pos1 Mod 50 = 0 And UBound(xx) < 500 Then

temp1 = UBound(xx) + 1

ReDim Preserve xx(temp1): ReDim Preserve yy(temp1)

ReDim Preserve jiaX(temp1): ReDim Preserve jiaY(temp1)

xx(temp1) = wid * Rnd: yy(temp1) = hei * Rnd

End If

For i = 0 To UBound(xx)

If hei - yy(i) < 150 Then jiaY(i) = False

If wid - xx(i) < 150 Then jiaX(i) = False

If yy(i) < 150 Then jiaY(i) = True

If xx(i) < 150 Then jiaX(i) = True

If jiaY(i) = True Then yy(i) = yy(i) + 50 Else yy(i) = yy(i) - 50

If jiaX(i) = True Then xx(i) = xx(i) + 50 Else xx(i) = xx(i) - 50

p.Circle (xx(i), yy(i)), 200, color1

Next

Case 20 ´起起落落

If pos1 hei - 2500 Then lihe = False

If lihe = False Then pos1 = pos1 - 30 Else pos1 = pos1 + 30

p.Cls

wid1 = wid / 2: hei1 = hei / 2

p.Line (wid1 - 800, hei - 500)-(wid1 + 800, hei), color1, BF

p.Circle (wid1, hei - 1500 - pos1), 1000, -color1, , , 1

Case 21 ´三维空间

wid1 = wid / 2: hei1 = hei / 2

If pos1 = (rectmax / 2) Then pos2 = 0: p.Cls: rectmax = Round(Rnd * 30) + 1

rnd1 = wid / rectmax: rnd2 = hei / (rectmax / 2)

If pos1 20 Then Exit Sub

p.ForeColor = color1

If pos1 hei / 10 Then lihe = False

If pos1 < 20 Then lihe = True

If lihe = True Then

pos1 = pos1 + 10: col1 = color1: col2 = -color1

Else

pos1 = pos1 - 10: col1 = -color1: col2 = color1

End If

p.Cls: wid1 = wid / 2: hei1 = hei / 2

temp1 = hei / 3 - pos1

p.Circle (wid1, hei1 - (temp1 / 3) + (pos1 * 3.5)), temp1, col1, , , pos1 / (hei / 10)

p.Circle (wid1, hei1 + (temp1 / 3) - (pos1 * 3.5)), temp1, col2, , , pos1 / (hei / 10)

Case 25 ´密集电网

If pos1 < hei Then pos1 = pos1 + 20 Else pos1 = 1

p.Line (0, hei - pos1)-(wid, hei), color1

p.Line (0, 0)-(wid, pos1), color1

p.Line (0, hei)-(wid, hei - pos1), color1

p.Line (wid, 0)-(0, pos1), color1

Case 26 ´滚动台词

str1 = "鱼儿失去了池塘，蚊虫困在了蛛网，抹不去的痕迹逃不掉的结局，无力的挣扎绝望的将近，虽然“静”" & _

"给我指引了迷途，让我勇敢的走下去，但内心实在太空虚太劳累，一次一次的痛强忍过后，灵魂的创伤却无法" & _

"愈合|我曾选择过睡觉、玩游戏逃避所有的痛，但却不忘告戒自己“最后一次”，不知多少次的“最后一次”，" & _

"逃避之后更难以忍受自己所做的行为，自责甚至骂自己是懦夫是邪恶的战俘，但具诱惑的解脱堕落最终我没有" & _

"去尝试，最中我还是选择了继续的压抑和勇敢的走下去，这种选择希望是属于每个人的"

If pos1 < hei + (p.FontSize * 20 * pos2) Then pos1 = pos1 + 10 Else pos1 = 1: pos2 = 0

p.Cls: p.ForeColor = color1

If pos2 = 0 Then ´计算逗号个数,为了增加滚动时限

i = 1

While InStr(i, str1, "，") 0

temp1 = InStr(i, str1, "，")

pos2 = pos2 + 1: i = temp1 + 1

Wend

End If

p.CurrentY = hei - pos1: p.Print Replace(Replace(str1, "，", vbCrLf), "|", vbCrLf & vbCrLf)

Case 27 ´夜空流星

p.Cls

If UBound(xx) hei + 500 Then yy(i) = 0

If xx(i) < -500 Then xx(i) = wid * Rnd + hei

yy(i) = yy(i) + 30: xx(i) = xx(i) - 30

p.Line (xx(i), yy(i))-(xx(i) + 500, yy(i) - 500), color1

Next

Case 28 ´随机变形

If 100 * Rnd wid1 / 2 Then pos1 = 0 Else pos1 = pos1 + 20

p.Circle (wid1 - (hei1 / 1.7), hei - (hei1 / 1.7)), pos1, p.BackColor

Case 30 ´旋转光线

pos1 = pos1 + 5: wid1 = wid / 2: p.Cls

If pos2 >= wid1 Then pos1 = 0: pos2 = 0

If pos1 Mod 600 = 0 Then

lihe = False

ElseIf pos1 Mod 300 = 0 Then

lihe = True

End If

If lihe = False Then pos2 = pos2 + ((pos1 / 250) * 10) Else pos2 = pos2 - ((pos1 / 250) * 10)

p.Line (wid1 - pos2, 0)-(wid1 - pos2, hei), color1

p.Line (wid1 + pos2, 0)-(wid1 + pos2, hei), -color1

Case 31 ´光之轨迹

If xx(0) < 500 Then jiaX(0) = True

If yy(0) < 500 Then jiaY(0) = True

If wid - xx(0) < 500 Then jiaX(0) = False

If hei - yy(0) < 500 Then jiaY(0) = False

If jiaX(i) = True Then xx(0) = xx(0) + 500 Else xx(0) = xx(0) - 500

If jiaY(i) = True Then yy(0) = yy(0) + 500 Else yy(0) = yy(0) - 500

If lihe = False Then

p.Line (xx(0), yy(0))-(xx(0), yy(0)), color1

lihe = True

Else

p.Line -(xx(0), yy(0)), color1

End If

Case 32 ´旋转回忆

If InStr(App.Path, "\") = Len(App.Path) Then path1 = App.Path Else path1 = App.Path & "\"

str1 = path1 & "甩哥.jpg"

Set pic1 = LoadPicture(str1): p.Cls: wid1 = wid / 2: hei1 = hei / 2

If pos1 < wid Then pos1 = pos1 + 10 Else pos1 = 0

If pos1 Mod 4000 = 0 Then

lihe = False

ElseIf pos1 Mod 2000 = 0 Then

lihe = True

End If

If lihe = True Then

pos2 = pos2 - 30

If pos2 < 40 Then lihe = False

Else

pos2 = pos2 + 30

End If

p.PaintPicture pic1, pos1, hei1 - (pic1.Height / 4), pos2

p.PaintPicture pic1, wid1 - (pic1.Width / 4), pos1 / 2, , (pos2 / 2)

p.PaintPicture pic1, wid - pos1, hei1 - (pic1.Height / 4), -pos2

p.PaintPicture pic1, wid1 - (pic1.Width / 4), hei - (pos1 / 2), , -(pos2 / 2)

Case 33 ´阿基米一

wid1 = wid / 2: hei1 = hei / 2:

If pos2 = 0 Then pos2 = Round(Rnd * 8) + 1

If pos1 < wid1 - (wid1 - hei1) Then pos1 = pos1 + 30 Else pos1 = 1: pos2 = 0: p.Cls: Exit Sub

For i = 0 To pos1 Step pos2

i = i + pos2

p.PSet (i * Cos(i) + wid1, i * Sin(i) + hei1), color1

Next

Case 34 ´阿基米二

wid1 = wid / 2: hei1 = hei / 2:

If pos1 < wid1 Then pos1 = pos1 + 10 Else pos1 = 1: pos2 = 0: p.Cls: Exit Sub

p.Line (wid1, hei1)-(pos1 * Cos(pos1) + wid1, pos1 * Sin(pos1) + hei1), color1

Case 35 ´阿基米三

wid1 = wid / 2: hei1 = hei / 2

If pos1 < wid1 Then pos1 = pos1 + 10 Else pos1 = 20: p.Cls: Exit Sub

p.Circle (wid1, hei1), pos1, color1

p.Line (wid1, hei1)-(pos1 * Cos(pos1) + wid1, pos1 * Sin(pos1) + hei1), -color1, BF

Case 36 ´声波探测

hei1 = hei / 2

If Rnd * 100 < 20 Then rnd1 = Rnd * hei1

If pos1 < wid Then pos1 = pos1 + 50 Else pos1 = 50: p.Cls

If pos1 = 50 Then

p.Line (pos1, rnd1 * Cos(rnd1) + hei1)-(pos1 + 50, rnd1 * Sin(rnd1) + hei1), color1

Else

p.Line -(pos1, rnd1 * Cos(rnd1) + hei1), color1

End If

Case 37 ´光辉四射

wid1 = wid / 2: hei1 = hei / 2: rnd1 = Rnd * wid1: rnd2 = hei1 / 5

If pos1 < wid1 Then pos1 = pos1 + (Rnd * 10) Else pos1 = 0

p.Line (rnd1 * Cos(pos1) + wid1, rnd1 * Sin(pos1) + hei1)-((Cos(pos1) * rnd2) + wid1, (Sin(pos1) * rnd2) + hei1), color1

p.FillColor = color1

p.Circle (wid1, hei1), rnd2, color1

Case 38 ´网状距阵

If pos1 < wid Then pos1 = pos1 + 10 Else pos1 = 0: p.Cls

color2 = 0

If pos1 = 0 Then

pos2 = Round(Rnd * 7): pos3 = color1

ElseIf pos1 Mod 100 = 0 Then

pos2 = Round(Rnd * 7): pos3 = color1: p.Cls

End If

While pos2 = 0

pos2 = Round(Rnd * 7)

Wend

p.FillStyle = pos2: p.FillColor = pos3

p.Line (0, 0)-(wid, hei), pos3, B

Case 39 ´圆形光线

wid1 = wid / 2: hei1 = hei / 2

If pos1 < wid1 Then pos1 = pos1 + 10 Else pos1 = 10: p.Cls

If pos1 = 10 Then

p.Line (wid1, hei1)-(wid1, hei1), color1

Else

p.Line -(pos1 * Sin(pos1) + wid1, pos1 * Cos(pos1) + hei1), color1

End If

End Select

End Sub