www.pudn.com > pm.zip > BLANKER.FRM
VERSION 5.00
Begin VB.Form DemoForm
BackColor = &H00000000&
Caption = "屏幕演示"
ClientHeight = 4380
ClientLeft = 960
ClientTop = 2535
ClientWidth = 7470
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Icon = "BLANKER.frx":0000
LinkMode = 1 'Source
LinkTopic = "Form1"
PaletteMode = 1 'UseZOrder
ScaleHeight = 4380
ScaleWidth = 7470
WhatsThisHelp = -1 'True
Begin VB.Timer Timer1
Interval = 1
Left = 6960
Top = 120
End
Begin VB.CommandButton cmdStartStop
BackColor = &H00000000&
Caption = "开始演示"
Default = -1 'True
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 390
Left = 240
TabIndex = 0
Top = 120
Width = 1830
End
Begin VB.PictureBox picBall
AutoSize = -1 'True
BackColor = &H00000000&
BorderStyle = 0 'None
ForeColor = &H00FFFFFF&
Height = 480
Left = 1800
Picture = "BLANKER.frx":030A
ScaleHeight = 480
ScaleWidth = 480
TabIndex = 1
Top = 720
Visible = 0 'False
Width = 480
End
Begin VB.Image imgMoon
Height = 480
Index = 8
Left = 6360
Picture = "BLANKER.frx":0614
Top = 3720
Visible = 0 'False
Width = 480
End
Begin VB.Line linLineCtl
BorderColor = &H00FF0000&
BorderWidth = 5
Visible = 0 'False
X1 = 240
X2 = 4080
Y1 = 2760
Y2 = 2760
End
Begin VB.Image imgMoon
Height = 480
Index = 7
Left = 5760
Picture = "BLANKER.frx":091E
Top = 3720
Visible = 0 'False
Width = 480
End
Begin VB.Image imgMoon
Height = 480
Index = 6
Left = 5160
Picture = "BLANKER.frx":0C28
Top = 3720
Visible = 0 'False
Width = 480
End
Begin VB.Image imgMoon
Height = 480
Index = 5
Left = 4560
Picture = "BLANKER.frx":0F32
Top = 3720
Visible = 0 'False
Width = 480
End
Begin VB.Image imgMoon
Height = 480
Index = 4
Left = 3960
Picture = "BLANKER.frx":123C
Top = 3720
Visible = 0 'False
Width = 480
End
Begin VB.Image imgMoon
Height = 480
Index = 3
Left = 3360
Picture = "BLANKER.frx":1546
Top = 3720
Visible = 0 'False
Width = 480
End
Begin VB.Image imgMoon
Height = 480
Index = 2
Left = 2760
Picture = "BLANKER.frx":1850
Top = 3720
Visible = 0 'False
Width = 480
End
Begin VB.Image imgMoon
Height = 480
Index = 1
Left = 2160
Picture = "BLANKER.frx":1B5A
Top = 3720
Visible = 0 'False
Width = 480
End
Begin VB.Image imgMoon
Height = 480
Index = 0
Left = 1560
Picture = "BLANKER.frx":1E64
Top = 3720
Visible = 0 'False
Width = 480
End
Begin VB.Shape shpClone
BackColor = &H00000000&
BackStyle = 1 'Opaque
BorderColor = &H00FF0000&
FillColor = &H000000FF&
Height = 1215
Index = 0
Left = 240
Top = 720
Visible = 0 'False
Width = 1410
End
Begin VB.Shape Shape1
Height = 15
Left = 960
Top = 1080
Width = 15
End
Begin VB.Menu mnuOption
Caption = "选项(&O)"
Begin VB.Menu mnuLineCtlDemo
Caption = "直线跳跃(&J)"
Checked = -1 'True
End
Begin VB.Menu mnuCtlMoveDemo
Caption = "圆月反弹(&B)"
End
Begin VB.Menu mnuImageDemo
Caption = "旋转月亮(&S)"
End
Begin VB.Menu mnuShapeDemo
Caption = "形色变幻(&M)"
End
Begin VB.Menu mnuPSetDemo
Caption = "五彩碎片(&C)"
End
Begin VB.Menu mnuLineDemo
Caption = "交叉火力(&R)"
End
Begin VB.Menu mnuCircleDemo
Caption = "彩虹地毯(&W)"
End
Begin VB.Menu mnuScaleDemo
Caption = "彩色方块(&L)"
End
Begin VB.Menu sep1
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "退出(&X)"
End
End
End
Attribute VB_Name = "DemoForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'--------------------------------------
'源程序的版权属原作者所有！
'所有源程序经过玫瑰雪儿检测，并保证通过。
'网名：玫瑰雪儿
'站点：rosesnow.onchina.net
'E_mail：zhaosihua@263.net
'欢迎访问我的网站，并提出宝贵意见或建议
'--------------------------------------
Option Explicit
' 声明一个追踪动画帧的变量
Dim FrameNum
' 声明追踪位置的 X- 和 Y-坐标变量
Dim XPos
Dim YPos
' 声明 Do Loops 中停止图像过程的变量标志
Dim DoFlag
' 声明追踪动态控件的变量
Dim Motion
' 声明代表三个基本色的变量
Dim R
Dim G
Dim B
Private Sub CircleDemo()
'声明局部变量
Dim Radius
' 创建随机RGB 颜色
R = 255 * Rnd
G = 255 * Rnd
B = 255 * Rnd
' 将圆心置在窗体中心
XPos = ScaleWidth / 2
YPos = ScaleHeight / 2
' 产生一个值在 0与几乎窗体高度一半之间的半径
Radius = ((YPos * 0.9) + 1) * Rnd
'在窗体上画一个圆
Circle (XPos, YPos), Radius, RGB(R, G, B)
End Sub
Private Sub cmdStartStop_Click()
' 声明局部变量
Dim UnClone
Dim MakeClone
Dim X1
Dim Y1
Select Case DoFlag
Case True
cmdStartStop.Caption = "开始演示"
DoFlag = False
mnuOption.Enabled = True
If mnuCtlMoveDemo.Checked = True Then
' 再次隐藏动态画面
picBall.Visible = False
ElseIf mnuLineDemo.Checked = True Then
' 从窗体上清除线条
Cls
ElseIf mnuShapeDemo.Checked = True Then
' 清除所有动态装载的模型控件
For UnClone = 1 To 20
Unload shpClone(UnClone)
Next UnClone
' 将窗体背景再设为黑色
DemoForm.BackColor = QBColor(0)
' 刷新窗体使颜色的改变产生作用
Refresh
ElseIf mnuPSetDemo.Checked = True Then
' 从窗体中删除彩色点
Cls
ElseIf mnuLineCtlDemo.Checked = True Then
' 再次隐藏 Line 控件
linLineCtl.Visible = False
' 隐藏 Line 控件后清除剩下的残图
Cls
ElseIf mnuImageDemo.Checked = True Then
' 再次隐藏动态图形
imgMoon(0).Visible = False
ElseIf mnuScaleDemo.Checked = True Then
' 清窗体
Cls
' 返回窗体到缺省的尺寸
Scale
ElseIf mnuCircleDemo.Checked = True Then
' 从窗体中清除圆
Cls
End If
Case False
cmdStartStop.Caption = "停止演示"
DoFlag = True
mnuOption.Enabled = False
If mnuCtlMoveDemo.Checked = True Then
' 使动态画面（picture box 控件）可见
picBall.Visible = True
' 随机设置动态画面中 motion变量值从1 到4，
' motion变量值决定运行 Do Loop 程序中的哪个部分
Motion = Int(4 * Rnd + 1)
ElseIf mnuLineDemo.Checked = True Then
' 初始化随机数产生器
Randomize
' 设置线宽
DrawWidth = 2
' 在窗体上随机设置X- 和 Y-坐标的初始位置
X1 = Int(DemoForm.Width * Rnd + 1)
Y1 = Int(DemoForm.Height * Rnd + 1)
ElseIf mnuShapeDemo.Checked = True Then
' 在窗体上动态加载含 20 个 模型控件的控件数组
For MakeClone = 1 To 20
Load shpClone(MakeClone)
Next MakeClone
ElseIf mnuPSetDemo.Checked = True Then
' 设置彩色点的厚度
DrawWidth = 5
ElseIf mnuLineCtlDemo.Checked = True Then
' 使（line） 控件可见
linLineCtl.Visible = True
' 设置线显示的厚度
DrawWidth = 7
ElseIf mnuImageDemo.Checked = True Then
' 使动态画面（image 控件）可见
imgMoon(0).Visible = True
' 设置初始动画帧
FrameNum = 0
'随机设置动态画面中 motion变量值从1 到4，
' motion变量值决定运行 Do Loop 程序中的哪个部分
Motion = Int(4 * Rnd + 1)
ElseIf mnuScaleDemo.Checked = True Then
' 初始化随机数产生器
Randomize
' 设置方块的轮廓宽度使方块间不重叠
DrawWidth = 1
' 设置 X-坐标值为窗体左边界
' 第一个方块的 X-坐标 = 1,第二个=2 依次类推
ScaleLeft = 1
' 设置窗体顶端的Y-坐标为10
ScaleTop = 10
' 设置窗体宽度上单元数为 3 到 12 之间的随机数，这将改变程序开始时所画的方块数。
ScaleWidth = Int(13 * Rnd + 3)
' 设置窗体高度上单元数为-10，所有方块的高度在0 到10 之间
' Y-坐标从窗体底部开始。
ScaleHeight = -10
ElseIf mnuCircleDemo.Checked = True Then
' 定义圆轮廓宽度
DrawWidth = 1
' 用射线方式画圆
DrawStyle = vbDash
' 用 XOR pen画线，用 pen 中或显示中的颜色画线，不能两者均使用
DrawMode = vbXorPen
End If
End Select
End Sub
Private Sub CtlMoveDemo()
Select Case Motion
Case 1
' 用MOVE方法将图向上向左移动 20 缇
picBall.Move picBall.Left - 20, picBall.Top - 20
' 如果图到达窗体左边界，向上向右移动
If picBall.Left <= 0 Then
Motion = 2
' 如果图到达窗体顶端，向下向左移动
ElseIf picBall.Top <= 0 Then
Motion = 4
End If
Case 2
' 将图向上向右移动 20 缇
picBall.Move picBall.Left + 20, picBall.Top - 20
' 如果图到达窗体右边界，向上向左移动
' 程序通过窗体宽度减去图宽度获得窗体右边界
If picBall.Left >= (DemoForm.Width - picBall.Width) Then
Motion = 1
' 如果图到达窗体顶端，向下向右移动
ElseIf picBall.Top <= 0 Then
Motion = 3
End If
Case 3
' 向下向右移动 20 缇
picBall.Move picBall.Left + 20, picBall.Top + 20
' 如果图到达窗体右边界，向下向左移动
If picBall.Left >= (DemoForm.Width - picBall.Width) Then
Motion = 4
' 如果图到达窗体底端，向上向右移动，程序通过窗体高度减去图高度
' 并减去主题条和菜单条占的680缇决定窗口底端
ElseIf picBall.Top >= (DemoForm.Height - picBall.Height) - 680 Then
Motion = 2
End If
Case 4
' 向下向左移动 20 缇
picBall.Move picBall.Left - 20, picBall.Top + 20
' 如果图到达窗体左边界，向下向右移动
If picBall.Left <= 0 Then
Motion = 3
' 如果图到达窗体底端，向上向左移动
ElseIf picBall.Top >= (DemoForm.Height - picBall.Height) - 680 Then
Motion = 1
End If
End Select
End Sub
Private Sub Delay()
Dim Start
Dim Check
Start = Timer
Do Until Check >= Start + 0.15
Check = Timer
Loop
End Sub
Private Sub Form_Load()
DoFlag = False
End Sub
Private Sub Form_Resize()
If mnuScaleDemo.Checked = True And DemoForm.WindowState = 0 Then
' 初始化随机数产生器
Randomize
' 将方块的轮廓宽度设窄使方块间不重叠
DrawWidth = 1
' 将窗体左边界 x坐标值设为1。
' 这将使定位每个方块位置更容易。第一个方块的X坐标值设为1。
' 第二个方块的X坐标值设为。以此类推。
ScaleLeft = 1
' 设置窗体顶端的Y-坐标为10
ScaleTop = 10
' 设置窗体宽度上单元数在 3 到 12 之间。
' 这将改变每次用户开始这个过程时所画的方块数。
ScaleWidth = Int(13 * Rnd + 3)
' 设置窗体高度上单元的数为-10。这样做有两种作用，首先所有方块高度值在0到10间改变。
' 其次，负值使Y坐标从窗体底部开始而不是顶部o
ScaleHeight = -10
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub ImageDemo()
Select Case Motion
Case 1
'用MOVE方法将图向上向左移动 100 缇。
imgMoon(0).Move imgMoon(0).Left - 100, imgMoon(0).Top - 100
' 动画到下一帧。
IncrFrame
' 如果图到达窗体左边界，向上向右移动。
If imgMoon(0).Left <= 0 Then
Motion = 2
' 如果图到达窗体顶端，向下向左移动。
ElseIf imgMoon(0).Top <= 0 Then
Motion = 4
End If
Case 2
'将图向上向右移动 100 缇。
imgMoon(0).Move imgMoon(0).Left + 100, imgMoon(0).Top - 100
' 动画到下一帧。
IncrFrame
' 如果到达窗体右边界，向上向左移动。
' 程序通过窗体宽度减去图宽度获得窗体右边界。
If imgMoon(0).Left >= (DemoForm.Width - imgMoon(0).Width) Then
Motion = 1
' 如果图到达窗体顶端，向下向右移动。
ElseIf imgMoon(0).Top <= 0 Then
Motion = 3
End If
Case 3
' 将图向下向右移动 100 缇。
imgMoon(0).Move imgMoon(0).Left + 100, imgMoon(0).Top + 100
' 动画到下一帧。
IncrFrame
' 如果到达右边界，向下向左移动。
If imgMoon(0).Left >= (DemoForm.Width - imgMoon(0).Width) Then
Motion = 4
' 如果图到达窗体底端，向上向右移动。
' 程序通过窗体高度减去图高度
' 并减去主题条和菜单条占的680缇决定窗口底端
ElseIf imgMoon(0).Top >= (DemoForm.Height - imgMoon(0).Height) - 680 Then
Motion = 2
End If
Case 4
' 将图向下向左移动 100缇。
imgMoon(0).Move imgMoon(0).Left - 100, imgMoon(0).Top + 100
' 动画到下一帧。
IncrFrame
' 如果图到达窗体左边界，向下向右移动。
If imgMoon(0).Left <= 0 Then
Motion = 3
' 如果图到达窗体底端，向上向左移动。
ElseIf imgMoon(0).Top >= (DemoForm.Height - imgMoon(0).Height) - 680 Then
Motion = 1
End If
End Select
End Sub
Private Sub IncrFrame()
' 帧数加1。
FrameNum = FrameNum + 1
' 动画帧控件数组有元素 0 到 元素 7，在最后一帧将帧设为第0帧使动画循环。
If FrameNum > 8 Then
FrameNum = 1
End If
' 将（IMAGE）控件的图像特性设为当前帧的图像特性。
imgMoon(0).Picture = imgMoon(FrameNum).Picture
' 延迟显示使动画不至太快。
Me.Refresh
Delay
End Sub
Private Sub LineCtlDemo()
' 在窗体上随机设线的起点坐标。
linLineCtl.X1 = Int(DemoForm.Width * Rnd)
linLineCtl.Y1 = Int(DemoForm.Height * Rnd)
'在窗体上随机设线的终点坐标。
linLineCtl.X2 = Int(DemoForm.Width * Rnd)
linLineCtl.Y2 = Int(DemoForm.Height * Rnd)
' 清屏
Cls
'在移动线之前延迟显示。
Delay
End Sub
Private Sub LineDemo()
' 局部变量声明
Dim X2
Dim Y2
' 创建随机 RGB 颜色
R = 255 * Rnd
G = 255 * Rnd
B = 255 * Rnd
' 在窗体上随机设(line)控件的终点位置。
X2 = Int(DemoForm.Width * Rnd + 1)
Y2 = Int(DemoForm.Height * Rnd + 1)
' 用（LINE）方法从当前坐标画到当前终点，颜色随机，每条线起点为上一条线的终点。
Line -(X2, Y2), RGB(R, G, B)
End Sub
Private Sub mnuCircleDemo_Click()
Cls
mnuCtlMoveDemo.Checked = False
mnuLineDemo.Checked = False
mnuShapeDemo.Checked = False
mnuPSetDemo.Checked = False
mnuLineCtlDemo.Checked = False
mnuImageDemo.Checked = False
mnuScaleDemo.Checked = False
mnuCircleDemo.Checked = True
End Sub
Private Sub mnuCtlMoveDemo_Click()
Cls
mnuCtlMoveDemo.Checked = True
mnuLineDemo.Checked = False
mnuShapeDemo.Checked = False
mnuPSetDemo.Checked = False
mnuLineCtlDemo.Checked = False
mnuImageDemo.Checked = False
mnuScaleDemo.Checked = False
mnuCircleDemo.Checked = False
End Sub
Private Sub mnuExit_Click()
End
End Sub
Private Sub mnuImageDemo_Click()
Cls
mnuCtlMoveDemo.Checked = False
mnuLineDemo.Checked = False
mnuShapeDemo.Checked = False
mnuPSetDemo.Checked = False
mnuLineCtlDemo.Checked = False
mnuImageDemo.Checked = True
mnuScaleDemo.Checked = False
mnuCircleDemo.Checked = False
End Sub
Private Sub mnuLineCtlDemo_Click()
Cls
mnuCtlMoveDemo.Checked = False
mnuLineDemo.Checked = False
mnuShapeDemo.Checked = False
mnuPSetDemo.Checked = False
mnuLineCtlDemo.Checked = True
mnuImageDemo.Checked = False
mnuScaleDemo.Checked = False
mnuCircleDemo.Checked = False
End Sub
Private Sub mnuLineDemo_Click()
Cls
mnuCtlMoveDemo.Checked = False
mnuLineDemo.Checked = True
mnuShapeDemo.Checked = False
mnuPSetDemo.Checked = False
mnuLineCtlDemo.Checked = False
mnuImageDemo.Checked = False
mnuScaleDemo.Checked = False
mnuCircleDemo.Checked = False
End Sub
Private Sub mnuPSetDemo_Click()
Cls
mnuCtlMoveDemo.Checked = False
mnuLineDemo.Checked = False
mnuShapeDemo.Checked = False
mnuPSetDemo.Checked = True
mnuLineCtlDemo.Checked = False
mnuImageDemo.Checked = False
mnuScaleDemo.Checked = False
mnuCircleDemo.Checked = False
End Sub
Private Sub mnuScaleDemo_Click()
Cls
mnuCtlMoveDemo.Checked = False
mnuLineDemo.Checked = False
mnuShapeDemo.Checked = False
mnuPSetDemo.Checked = False
mnuLineCtlDemo.Checked = False
mnuImageDemo.Checked = False
mnuScaleDemo.Checked = True
mnuCircleDemo.Checked = False
End Sub
Private Sub mnuShapeDemo_Click()
Cls
mnuCtlMoveDemo.Checked = False
mnuLineDemo.Checked = False
mnuShapeDemo.Checked = True
mnuPSetDemo.Checked = False
mnuLineCtlDemo.Checked = False
mnuImageDemo.Checked = False
mnuScaleDemo.Checked = False
mnuCircleDemo.Checked = False
End Sub
Private Sub PSetDemo()
' 创建随机 RGB 颜色
R = 255 * Rnd
G = 255 * Rnd
B = 255 * Rnd
' XPos 决定彩色点在窗体中的随机水平位置
XPos = Rnd * ScaleWidth
' YPos 决定彩色点在窗体中的随机垂直位置
YPos = Rnd * ScaleHeight
' 以随机色在 XPos, YPos 画一个彩色点
PSet (XPos, YPos), RGB(R, G, B)
End Sub
Private Sub ScaleDemo()
' 局部变量声明
Dim Box
' 创建和窗体宽度的单元数相同的方块数。
For Box = 1 To ScaleWidth
' 创建随机 RGB 颜色
R = 255 * Rnd
G = 255 * Rnd
B = 255 * Rnd
' 用 Line 方法的 BF 选项画方块。ScaleWidth决定每个方块的X-坐标，且 Y-坐标为 0。
' 每个方块宽为 1，高在 0 到 10 之间。颜色随机
Line (Box, 0)-Step(1, (Int(11 * Rnd))), RGB(R, G, B), BF
Next Box
' 重画前延迟显示所有方块。
Delay
End Sub
Private Sub ShapeDemo()
' 局部变量声明
Dim CloneID
' 创建随机 RGB 颜色
R = 255 * Rnd
G = 255 * Rnd
B = 255 * Rnd
' 设置窗体背景色为随机值
DemoForm.BackColor = RGB(R, G, B)
' 在控件数组中随机选择控件
CloneID = Int(20 * Rnd + 1)
' 在窗体中随机设置模型控件显示坐标
XPos = Int(DemoForm.Width * Rnd + 1)
YPos = Int(DemoForm.Height * Rnd + 1)
' 在被选模型控件中随机设模型
shpClone(CloneID).Shape = Int(6 * Rnd)
' 被选模型控件宽和高随机设为 500 到 2500 缇之间
shpClone(CloneID).Height = Int(2501 * Rnd + 500)
shpClone(CloneID).Width = Int(2501 * Rnd + 500)
' 设置背景色，模型控件的DrawMode特性为随机色。
shpClone(CloneID).BackColor = QBColor(Int(15 * Rnd))
shpClone(CloneID).DrawMode = Int(16 * Rnd + 1)
' 移动选定的模型控件至 XPos, YPos
shpClone(CloneID).Move XPos, YPos
' 使被选定的模型控件可见
shpClone(CloneID).Visible = True
' 在选择并改为下一个模型控件前延迟一会
Delay
End Sub
Private Sub Timer1_Timer()
If mnuCtlMoveDemo.Checked And DoFlag = True Then
CtlMoveDemo
ElseIf mnuLineDemo.Checked And DoFlag = True Then
LineDemo
ElseIf mnuShapeDemo.Checked And DoFlag = True Then
ShapeDemo
ElseIf mnuPSetDemo.Checked And DoFlag = True Then
PSetDemo
ElseIf mnuLineCtlDemo.Checked And DoFlag = True Then
LineCtlDemo
ElseIf mnuImageDemo.Checked And DoFlag = True Then
ImageDemo
ElseIf mnuScaleDemo.Checked And DoFlag = True Then
ScaleDemo
ElseIf mnuCircleDemo.Checked And DoFlag = True Then
CircleDemo
End If
End Sub