# Timer 控件应用方案

## 知识概述

#### 1．功能

引发 Timer 事件，Timer 控件可以有规律地隔一段时间执行一次代码。

#### 2．属性

Timer 控件的属性如表 1 所示。

表 1 Timer 控件的常用属性

编号 | 属性 | 说明
1 | Enabled | 返回或设置一个值，该值用来确定 Timer 控件是否能够对产生的事件作出反应
2 | Interval | 返回或设置对 Timer 控件的计时事件中调用时间间隔的毫秒数

下面对比较重要的属性进行详细介绍。

（1）Enabled 属性

返回或设置一个值，该值用来确定 Timer 控件是否能够对产生的事件作出反应。

语法：

object.Enabled [= boolean]

object：对象表达式。

boolean：一个用来指定 object 是否能够对用户产生的事件作出反应的布尔表达式。当设置值为 True 时，允许对事件作出反应；当设置值为 False 时，阻止对 Timer 事件作出反应。

示例：

下例实现的是，在窗体运行的时候，单击窗体中的“切换背景”按钮，将触发时钟控件的 Timer 事件，使窗体的背景颜色以不同的颜色切换显示。

在设计程序时，首先在属性窗口中将时钟控件的 Enabled 属性设置为 False，在程序运行时单击“切换背景”按钮，将控件的 Enabled 属性设置为 True，触发控件的 Timer 事件。如图 1 和图 2 所示。

图 1 切换背景

图 2 切换背景

程序主要代码如下：

单击“切换背景”按钮实现的程序代码：

Dim i

'一秒钟后切换背景颜色

Private Sub Command1_Click()

Timer1.Enabled = True

Timer1.Interval = 1000

End Sub

时钟控件 Timer 事件的程序代码：

'根据属性值不同设置窗体背景颜色

Private Sub Timer1_Timer()

If i = 0 Then

Me.BackColor = &H80C0FF

i = 1

ElseIf i = 1 Then

Me.BackColor = &HFFC0FF

i = 0

End If

End Sub

程序完整代码如下：

Dim i

'一秒钟后切换背景颜色

Private Sub Command1_Click()

Timer1.Enabled = True

Timer1.Interval = 1000

End Sub

'根据属性值不同设置窗体背景颜色

Private Sub Timer1_Timer()

If i = 0 Then

Me.BackColor = &H80C0FF

i = 1

ElseIf i = 1 Then

Me.BackColor = &HFFC0FF

i = 0

End If

End Sub

（2）Interval 属性

返回或设置对 Timer 控件的计时事件中调用时间间隔的毫秒数。

语法：

object.Interval [= milliseconds]

object：对象表达式。

milliseconds：数值表达式，指定毫秒数。设置值的范围为 1～65536，在 Timer 控件的 Enabled 属性设置为 True 时开始有效。当设置值为 0 时，Timer 控件无效。

示例：

下例中，在程序运行时，通过调整滚动条的位置可以设置 Timer 控件的 Interval 属性值，并且将设置的 Interval 属性值显示在标签控件中，如图 3 所示。

图 3 设置时钟控件的 Interval 属性值

程序主要代码如下：

'窗体启动并初始化

Private Sub Form_Load()

Timer1.Interval = 400 ' 设置时间间隔。

HScroll1.Min = 100: HScroll1.Max = 500

End Sub

'获得 Timer 控件的 Interval 属性值

Private Sub HScroll1_Change()

Timer1.Interval = 500 - HScroll1.Value ' 根据滚动条的数值设置时间间隔。

Label1.Caption = "此时 Timer 控件的 Interval 属性值为：" & Timer1.Interval

End Sub

程序完整代码如下：

'窗体启动并初始化

Private Sub Form_Load()

Timer1.Interval = 400 ' 设置时间间隔。

HScroll1.Min = 100: HScroll1.Max = 500

End Sub

'获得 Timer 控件的 Interval 属性值

Private Sub HScroll1_Change()

Timer1.Interval = 500 - HScroll1.Value ' 根据滚动条的数值设置时间间隔。

Label1.Caption = "此时 Timer 控件的 Interval 属性值为：" & Timer1.Interval

End Sub

#### 3．事件

时钟控件只有一个 Timer 事件。Timer 事件在一个 Timer 控件预定的时间间隔过去之后发生。该间隔的频率储存于 Timer 控件的 Interval 属性中，并且以 1/1000s 为单位指定时间的长度。

语法：

Private Sub object_Timer([index As Integer])

object：对象表达式。

index：一个整数，用来惟一地标识一个在控件数组中的控件

## 应用一：闪烁的窗体标题栏

### 实例说明

在运行多个程序或文件时，会出现多个窗体，那么当前操作的窗体是哪一个呢？这让用户很难分辨。本例将用窗体标题栏不停的闪烁的方法，来提醒用户正在操作着的窗体是哪个窗体。运行程序，单击“开始演示”按钮，窗体标题栏开始闪烁，而且窗体文字不停变换；单击“停止演示”窗体标题栏停止闪烁；单击“退出”按钮，退出程序。效果如图 4 所示。

图 4 效果图

### 思路与技术

用 Flashwindow 函数，可以使一个特定的窗口闪烁一次；在 Timer 事件过程中可以使窗口标题栏达到不停闪烁的效果。下面是 Flashwindow 函数声明及参数：

函数声明：

FlashWindow(Byval hwnd as long, Byval bInvert as long ) as long

参数：hwnd 参数，为窗口句柄；bInvert 参数，为“0”，窗体标题栏不闪烁；bInvert 参数为“1”，窗体标题栏闪烁。

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，默认名为 Form1。

（2）在窗体上放置三个 Command 控件一个 Timer 控件。

（3）程序代码：

'声明 API 函数 Flashwindow

Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, _

ByVal bInvert As Long) As Long

'闪烁的窗体标题栏

Private Sub Timer1_Timer()

Call FlashWindow(hwnd, 1) 调用 FlashWindow 函数

If Form1.Caption = "闪烁标题栏" Then

Form1.Caption = "欢迎使用！ "

Else

Form1.Caption = "闪烁标题栏"

End If

End Sub

Private Sub Command1_Click() '开始演示

Timer1.Enabled = True '时间控件可用

End Sub

Private Sub Command2_Click() '停止演示

Timer1.Enabled = False '时间控件不可用

End Sub

Private Sub Command3_Click() '退出

Unload Me

End Sub

## 应用二：漂亮的数字钟

### 实例说明

Windows 任务栏上的时间看上去很单调，而且看不到每秒钟的变化。本例将讲解如何实现一个可以看到每秒变化的漂亮的数字钟。运行程序，在窗体上将显示漂亮的数字钟。效果如图 5 所示。

图 5 效果图

### 思路与技术

运用 Format 函数将日期分别格式化为小时、分钟、秒。在 Timer 事件中，显示时间每秒钟的变化。下面是 Format 函数的功能、语法及参数：

Format 函数功能：返回 Variant (String)，其中含有一个表达式，它是根据格式表达式中的指令来格式化的。

语法：

Format(expression[,format[,firstdayofweek[,firstweekofyear]]])

参数：

l expression 必要参数。任何有效的表达式。

l format 可选参数。有效的命名表达式或用户自定义格式表达式。

l firstdayofweek 可选参数。常数，表示一星期的第一天。

l firstweekofyear 可选参数。常数，表示一年的第一周。

说明：

数字 使用预先定义的命名数值格式或创建用户自定义数值格式。

日期和时间 使用预先定义的命名日期/时间格式或创建用户自定义日期/时间格式。

日期和时间序数 使用日期和时间格式或数值格式。

字符串 创建自定义的字符串格式。

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，默认名为 Form1。

（2）在 Form1 窗体中放置一个 Image 控件、三个 Label 控件、一个 Timer 控件。

（3）程序代码：

'窗体启动，显示时间

Private Sub Form_Load()

Label1.Caption = Format(Hour(Time), "00") & ":" '显示小时

Label2.Caption = Format(Minute(Time), "00") & ":" '显示分钟

Label3.Caption = Format(Second(Time), "00") '显示秒

End Sub

'分等于 60，时加 1

Private Sub Label2_Change()

If Label2.Caption = "60" Then Label1.Caption = Format(Hour(Time), "00") + 1 & ":"

End Sub

'秒等于 60，分加 1

Private Sub Label3_Change()

If Label3.Caption = "60" Then Label2.Caption = Format(Minute(Time), "00") + 1 & ":"

End Sub

Private Sub Timer1_Timer()

Label3.Caption = Time '显示系统时间

End Sub

## 应用三：利用 Image 制作小动画

### 实例说明

本例讲解如何运用 Image 控件制作小动画。运行程序，单击“演示”按钮，动画开始播放；单击“停止”按钮，动画即可停止。效果如图 6 所示。

图 6 效果图

### 思路与技术

在 Timer 事件过程中，通过循环调用一组不同的图片，便形成了动画效果。运用 Image 控件来显示图形，Image 控件可以显示来自位图、图标或元文件的图形，也可以显示增强的元文件、JPEG 或 GIF 文件。Image 控件使用较少的系统资源，重画起来比 PictureBox 控件要快。

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，默认名为 Form1。

（2）在 Form1 窗体中放置一个 Image 控件、一个 Text 控件、一个 Timer 控件、三个 Command 控件。

（3）程序代码：

Dim i As Integer

'窗体启动并设置变量的值

Private Sub Form_Load()

i = 0

End Sub

'用 Timer 事件调用图片

Private Sub Timer1_Timer()

i = i + 1

Image1.Picture = LoadPicture(App.Path & "\dh\" & i & ".jpg") '调用图片

If i = 25 Then i = 0

End Sub

Private Sub Command1_Click() '演示动画

Timer1.Interval = 50

End Sub

Private Sub Command2_Click() '停止动画

Timer1.Interval = 0

End Sub

'结束程序

Private Sub Command3_Click()

End

End Sub

## 应用四：北京奥运会倒计时程序

### 实例说明

本实例演示一个北京奥运会倒计时的程序。运行程序，在窗体上将显示距离 2008 年北京奥运会的具体时间，包括具体的年数、月数、天数、小时和秒数，如图 7 所示。

图 7 北京奥运会倒计时程序

### 思路与技术

Microsoft Chart 控件是一个数据绑定控件，允许以图形方式表示数值数据。不像其他数据绑通过 DateDiff 函数计算剩余的具体时间。

DateDiff 函数返回 Variant (Long)的值，表示两个指定日期间的时间间隔数目。

DateDiff 函数的语法格式如下：

DateDiff(interval, date1, date2[, firstdayofweek[, firstweekofyear]])

参数说明：

l interval 必要。字符串表达式，表示用来计算 date1 和 date2 的时间差的时间间隔。

l date1、date2 必要；Variant (Date)。计算中要用到的两个日期。

l firstdayofweek 可选。指定一个星期的第一天的常数。如果未指定，则以星期日为第一天。

l firstweekofyear 可选。指定一年的第一周的常数。如果未指定，则以包含 1 月 1 日的星期为第一周。

开发步骤

（1）新建一个标准工程，创建一个新窗体。

（2）在窗体上添加一个 Label 控件，Caption 属性设置为“2008 年北京奥运会”。

（3）在窗体上添加 2 个 Frame 控件，在 Frame1 控件上添加 2 个 Label 控件和 2 个 TextBox 控件。将 Frame2 控件的 Caption 属性设置为“距离 2008 年在北京召开的奥运会还有：”，然后，在 Frame2 控件上添加 5 个 Label 控件和 5 个 TextBox 控件。

（4）在窗体上添加两个 Timer 控件，Interval 属性分别设置为 60 和 1000。

注意：

关于窗体中控件的颜色设置，限于篇幅，不做介绍。

Form1 窗体中控件部分属性设置如表 2 所示。

表 2 Form1 窗体中控件部分属性设置

控件名 | 属性 | 值
Frame | Name | Frame1
Frame | Name Caption ForeColor | Frame2 距离 2008 年在北京召开的奥运会还有： &H00800000&
Label | Name Caption ForeColor | Label1 2008 年北京奥运会 &H00C000C0&
Label | Name Caption ForeColor | Label2 查看具体还有几年： &H00800080&
Label | Name Caption ForeColor | Label13 查看具体还有几个月： &H00800080&
Label | Name Caption ForeColor | Label8 查看具体还有几天： &H00800080&
Label | Name Caption ForeColor | Label11(0) 查看具体还有多少小时： &H00800080&
Label | Name Caption ForeColor | Label11(1) 查看具体还有多少秒： &H00800080&
Label | Name Caption ForeColor | Label9 当前时间 &H80000001&
Label | Name Caption ForeColor | Label10 奥运会开幕时间 &H80000001&
TextBox | Name | Text1
TextBox | Name Text | Text8 2008 年 8 月 8 日晚 8 时 星期五
TextBox | Name | Txt_days
TextBox | Name | Txt_hours
TextBox | Name | Txt_months
TextBox | Name | Txt_now
TextBox | Name | Txt_years
Timer | Name | Timer1
Timer | Name | Timer2

（5）为 Form1 窗体添加如下代码。

Dim Date1, Date2 As Date

Dim TxtYear As String

Dim TxtDays As Long

Dim NUmDays As Long

Dim TxtDate As String

'窗体启动并进行初始化

Private Sub Form_Load()

Me.Left = (Screen.Width - Me.Width) / 2

Me.Top = (Screen.Height - Me.Height) / 2

Date2 = "2008-08-08 20:0:0"

End Sub

' 调用 Timer 赋值

Private Sub Timer1_Timer()

Txt_now = Now

End Sub

' 调用 Timer 赋值

Private Sub Timer2_Timer()

Txt_days.Text = DateDiff("d", Date, Date2)

Txt_hours.Text = DateDiff("h", Date, Date2)

Txt_months.Text = DateDiff("m", Date, Date2)

Txt_years.Text = DateDiff("yyyy", Date, Date2)

Text1.Text = DateDiff("s", Time, Date2)

End Sub

## 应用五：彩虹文字

实现彩虹文字主要应用到了 API 函数，将其和 Timer 控件结合，再利用 Rnd 函数生成随机的颜色。下面介绍相关的 API 函数及其功能，如表 3 所示。

表 3 彩虹文字中应用到的 API 函数及其功能

函数 | 功能
BeginPath | 抛弃选入指定设备场景中的所有路径。也取消目前正在进行的任何路径的创建工作
TextOut | 文本绘图函数
EndPath | 停止定义一个路径
SelectClipPath | 将设备场景当前的路径合并到剪切区域里
AbortPath | 抛弃选入指定设备场景中的所有路径。也取消目前正在进行的任何路径的创建工作

下例主要实现了彩虹文字，程序的执行效果如图 8 所示。

图 8 彩虹文字演示

程序完整代码如下：

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function AbortPath Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function SelectClipPath Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long

Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long

Private Const RGN_COPY = 5

Private Sub DrawRainbow() '自定义函数

Dim i As Integer

For i = 0 To Me.ScaleHeight - 1 Step 4

Line (0, i)-(ScaleWidth, i + 4), QBColor(Int(16 * Rnd)), BF

Next i

End Sub

'窗体加载并初始化

Private Sub Form_Load()

Randomize

Me.ScaleMode = vbPixels

Me.DrawWidth = 2

Me.Font.Name = "宋体"

Me.Font.Size = 36

Me.Font.Bold = True

Me.Font.Italic = True

End Sub

'调用 Timer 事件实现彩虹文字效果

Private Sub Timer1_Timer()

Dim Ret As Long

Dim MyStr As String

MyStr = "彩虹文字演示"

Ret = BeginPath(Me.hdc)

Ret = TextOut(Me.hdc, 0, 0, MyStr, 2 * Len(MyStr))

Ret = EndPath(Me.hdc)

Ret = SelectClipPath(Me.hdc, RGN_COPY)

Ret = AbortPath(Me.hdc)

Call DrawRainbow

End Sub

## 应用六：产品展示程序

### 实例说明

一些商家为了推广产品将产品图片印刷成小册子进行展示或宣传，但由于长时间的翻看或携带会使产品宣传手册丢失或损坏。随着信息化的发展，可以使用现代化的手段将产品图片制作成产品演示光盘，从而避免上述情况的发生。运行程序，浏览产品图片及相关信息，如图 9 所示，单击“下一页”可以查看下一页产品图片及相关信息。单击产品缩略图，该产品将放大显示在另外一个窗体中，开始显示时，还有一个动画效果，如图 10 所示。通过放大的产品图片，用户可以清楚地了解该产品。

图 9 产品展示 1

图 10 产品展示 2

### 思路与技术

动画是一种运动的模拟，也可以说是不同图画一帧一帧逐个出现的效果，其实现方法是在屏幕上快速地显示一组相关的图像。因此，实现动画的基础是图像的显示和使图像快速、定时地移动或变化。动画由两个基本部分组成：一是物体相对于屏幕的运动，即屏幕级动画；二是物体内部的运动，即相对符号的动画。制作动画的原理就是画完一幅图形，清除它的屏幕显示部分，再在新位置画第二幅图形，如此交替下去，利用人眼的视觉效应就可以产生动画效果。VB 实现动画的原理也是如此，其实现方法有以下两种：

（1）在 Visual Basic 中，用 LoadPicture 函数可以将 BMP、ICO 和 WMF 格式的图像文件装入内存，并将其返回值赋予 Image 控件的 Picture 属性，从而显示图像。

用 Image 控件的 Move 方法移动图像，其 Left 和 Top 属性指示 Image 控件的当前左上角位置。

调用 LoadPicture 函数装载不同的图像，并赋给 Image 控件的 Picture 属性，将在控件中显示不同的图像即实现图像变化。

修改 Image 控件的 Width 或 Height 属性可以缩放控件。使用 Timer 控件可以实现定时控制。Timer 控件的 Interval 属性设置定时间隔，即调用 Timer 事件过程的时间间隔。在 Timer 事件过程中控制 Image 控件的移动或变化便能实现动画。Timer 控件的 Interval 值决定了动画的变化或移动速度，其单位是毫秒（1/1000 秒）。Timer 控件的 Enabled 属性决定了 Timer 事件是否有效。设置 Enabled 属性为 True，将启动 Timer 事件（如启动动画）；为 False 则使 Timer 事件无效（如停止动画）。

（2）控制方法

采用控制移动技术可以实现屏幕级动画，而控制移动方式又分两种：一是在程序运行过程中，随时更改控制的位置坐标 Left 和 Top 属性，使控制出现动态；二是对控制调用 Move 方法，产生移动的效果。这里的控制可以是命令按钮、文本框、图形框、图像框及标签等。

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，默认的“名称”属性为 Form1。

（2）在 Form1 窗体上添加一个 Shape 控件数组（Shape1(0)～Shape1(4)）、一个 Label 控件数组（Label1(0)～Label1(4)），一个 Image 控件数组（Image1(0)～Image1(4)）、一个 PictureBox 控件和两个 Label 控件。

（3）设置 Picture1 控件的 Picture 属性为事先设计好的图片（本书程序所在目录下 pic 文件夹中的 p01.jpg）。

（4）选择 VB 菜单的“工程”→“引用”，然后选取 Microsoft ActiveX Data Objects 2.5 Library，单击“确定”按钮。此时，ADO 对象群中的 Connection、Recordset、Command 和 Fields 等对象才会成为程序可以引用的对象。

（5）选择 VB 菜单的“工程”→“添加窗体”，添加一个新窗体，默认的“名称”属性为 Form2。

（6）在 Form2 窗体上添加一个 Timer 控件和一个 Image 控件。

Form1 窗体中控件部分属性设置如表 4 所示。

表 4 Form1 窗体中控件部分属性设置

控件名 | 属性 | 值
Image | Name | Image1(0)
Image | Name | Image1(1)
Image | Name | Image1(2)
Image | Name | Image1(3)
Image | Name | Image1(4)
Label | Name | Label1(0)
Label | Name | Label1(1)
Label | Name | Label1(2)
Label | Name | Label1(3)
Label | Name | Label1(4)
Label | Name | lblNext
Label | Name | lblPrevious
PictureBox | Name | Picture1
Shape | Name | Shape1(0)
Shape | Name | Shape1(1)
Shape | Name | Shape1(2)
Shape | Name | Shape1(3)
Shape | Name | Shape1(4)

Form2 窗体中控件部分属性设置如表 5 所示。

表 5 Form2 窗体中控件部分属性设置

控件名 | 属性 | 值
Image | Name | Image1
Timer | Name | Timer1

（7）为 Form1 窗体添加如下代码。

Dim rs1 As New ADODB.Recordset '创建 Recordset 对象

Dim Cn As New ADODB.Connection '创建 Connection 对象

Dim str As String '声明字符串类型变量

Dim i As Integer, j As Integer, a As Integer '声明整型变量

Private Sub Form_Load()

Cn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & App.Path & "\cpgl.mdb" '连接数据库

'按照升序查询商品信息表中记录

rs1.Open "商品信息表 order by 编号", Cn, adOpenKeyset, adLockOptimistic

If rs1.RecordCount > 0 Then '当记录数大于 0

i = 0

For j = 1 To 5 '循环

'加载图片

Image1(j - 1).Picture = LoadPicture(App.Path & "\" & rs1.Fields("图片"))

Label1(j - 1) = "编号:" & rs1.Fields("编号") & Chr(13) & "品名:" & rs1.Fields("品名") & Chr(13) & "规格:" & rs1.Fields("规格") '显示标签内容

rs1.MoveNext '记录集指针下移

Next j

End If

lblPrevious.Enabled = False '禁用标签 lblPrevious

End Sub

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

lblNext.ForeColor = &H80000012 '设置标签文字颜色

lblPrevious.ForeColor = &H80000012

lblNext.Font.Underline = False '没有下划线

lblPrevious.Font.Underline = False

End Sub

Private Sub Image1_Click(Index As Integer)

Form2.Image1.Picture = Image1(Index).Picture '设置窗体 Form2 中的 Image1 图像

Form2.Show 1 '显示窗体 Form2

End Sub

Private Sub lblNext_Click()

'当 i 的值小于将记录数除以 5 并四舍五入后的值时将 i 的值加 1

If i < Round(rs1.RecordCount / 5) Then i = i + 1

For j = 5 * i + 1 To 5 * (i + 1) '循环

a = j Mod 5 'a 等于 j 除以 5 的余数

If a = 0 Then a = 5 '当 a 等于 0 就将 a 设置为 5

If rs1.EOF = True Then '当记录集 rs1 中记录指针位于 EOF

Image1(a - 1).Picture = LoadPicture("") '清空图像

Label1(a - 1) = "" '清空标签内容

lblNext.Enabled = False '将标签 lblNext 禁用

Else

On Error Resume Next '忽略错误

If rs1.Fields("图片") <> "" Then '图片内容不为空字符串时

Image1(a - 1).Picture = LoadPicture(App.Path & "\" & rs1.Fields("图片")) '加载图片

Label1(a - 1) = "编号:" & rs1.Fields("编号") & Chr(13) & "品名:" & rs1.Fields("品名") & Chr(13) & "规格:" & rs1.Fields("规格")

Else

Image1(a - 1).Picture = LoadPicture("") '清空控件数组 Image1 图像

Label1(a - 1) = "" '清空标签内容

End If

End If

rs1.Move 1 '指针移动到第一条记录

Next j

lblPrevious.Enabled = True '标签 lblPrevious 可用

End Sub

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

lblNext.ForeColor = &HFF0000 '设置标签 lblNext 的文字颜色

lblNext.Font.Underline = True '文字带有下划线

End Sub

Private Sub lblPrevious_Click() '前一条

If i > 1 Then i = i - 1

For j = 5 * i + 1 To 5 * (i + 1)

a = j Mod 5

If a = 0 Then a = 5

If rs1.BOF = True Then

Image1(a - 1).Picture = LoadPicture("")

Label1(a - 1) = ""

lblPrevious.Enabled = False

Else

On Error Resume Next

If rs1.Fields("图片") <> "" Then

Image1(a - 1).Picture = LoadPicture(App.Path & "\" & rs1.Fields("图片"))

Label1(a - 1) = "编号:" & rs1.Fields("编号") & Chr(13) & "品名:" & rs1.Fields("品名") & Chr(13) & "规格:" & rs1.Fields("规格")

Else

Image1(a - 1).Picture = LoadPicture("")

Label1(a - 1) = ""

End If

End If

rs1.MovePrevious

Next j

lblNext.Enabled = True

End Sub

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

lblPrevious.ForeColor = &HFF0000

lblPrevious.Font.Underline = True

End Sub

（8）为 Form2 窗体添加如下代码。

Private Sub Form_Load() '设置 Image1 高度与宽度，Timer1 的延时为 100 毫秒

Image1.Width = 50

Image1.Height = 6495

Timer1.Interval = 100

End Sub

Private Sub Timer1_Timer()

If Image1.Width < 1100 Then '当 Image1 宽度小于 1100

Image1.Width = Image1.Width + 100 'Image1 宽度加 100

Else

Image1.Width = 1100 'Image1 宽度设置为 1100

Timer1.Interval = 0 '停用 Timer1

End If

End Sub

## 应用七：电影胶片特效

### 实例说明

在多媒体软件中，如果让相关图片按顺序循环滚动（例如循环展示商品图片），多媒体程序一定会增色不少。运行程序，在窗体中将从左到右连续播放不同的图片，呈现了一种电影胶片的效果，并且每张胶片中的图片都在不断地动态变换，效果如图 11 所示。

图 11 电影胶片特效

### 思路与技术

在窗体中放置一个 PictureBox 控件数组，通过在 Timer 控件中控制显示 PictureBox 控件数组中元素的移动来实现电影胶片的特殊效果。

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，设置其 Caption 属性为“电影胶片特效”。

（2）在窗体上添加一个 PictureBox 控件数组（Picture1(0)～Picture1(3)），分别设置控件的 Picture 属性，在控件上加载图片。

（3）在窗体上添加一个 Timer 控件。

From1 窗体中控件部分属性设置如表 6 所示。

表 6 From1 窗体中控件部分属性设置

控件名 | 属性 | 值
PictureBox | Name | Picture1(0)
PictureBox | Name | Picture1(1)
PictureBox | Name | Picture1(2)
PictureBox | Name | Picture1(3)
Timer | Name | Timer1
Timer | Name | Timer2

（4）为 Form1 窗体添加如下代码。

Dim x As Integer '声明整型变量

Private Sub Form_Load()

Picture1(0).Left = 0 '设置索引为 0 的 Picture1 数组元素的左端坐标为 0

Picture1(1).Left = Picture1(0).Width '设置 Picture1(1)左端坐标

Picture1(2).Left = Picture1(0).Width + Picture1(0).Width '设置 Picture1(2)左端坐标

Picture1(3).Left = -Picture1(3).Width '设置 Picture1(3)左端坐标

Picture1(3).Top = Picture1(0).Top '设置 Picture1(2)顶端坐标

x = 10

Timer1.Enabled = False '禁用 Timer1

Timer1.Interval = 10 'Timer1 的延时 10 毫秒

Timer2.Interval = 60 'Timer2 的延时 60 毫秒

End Sub

Private Sub Timer1_Timer()

For i = 0 To 3 '循环

Picture1(i).Left = Picture1(i).Left + x '设置 Picture1 控件数组元素左端坐标

'如果 Picture1 控件数组元素左端坐标大于窗体内部宽度

If Picture1(i).Left >= Form1.ScaleWidth Then

Picture1(i).Left = -Picture1(i).Width '设置 Picture1 控件数组元素左端坐标

End If

Next i

End Sub

Private Sub Timer2_Timer()

For i = 0 To 3 '循环

Dim k As Integer '声明整型变量

k = Int(1 + 11 * Rnd(10)) '生成随机数

'加载图片

Picture1(i).Picture = LoadPicture(App.Path & "\图片\" & k & ".jpg")

Next i

Timer1.Enabled = True '启用 Timer1

End Sub

## 应用八：滚动字幕

### 实例说明

在电视节目中，经常会有滚动的广告字幕。如何在程序中实现滚动字幕的效果呢？本例将向您讲解实现该功能的方法。运行程序，单击“演示”按钮，字幕开始水平滚动；单击“暂停”按钮，字幕停止滚动。效果如图 12 所示。

图 12 效果图

### 思路与技术

在 Timer 事件中，控制 label 控件的 left 属性值，从而实现滚动字幕的效果。

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，默认名为 Form1。

（2）在 Form1 窗体中放置一个 Timer 控件、一个 Label 控件、三个 Command 控件。

（3）程序代码：

Private Sub Timer1_Timer() '滚动字幕

If Label1.Left < 4700 Then

Label1.Left = Label1.Left + 100

Else

Label1.Left = 4700

End If

If Label1.ForeColor = &HFF0000 Then

Label1.ForeColor = &HFF&

Else

Label1.ForeColor = &HFF0000

End If

End Sub

Private Sub Command1_Click() '开始演示

Timer1.Enabled = True

Label1.Left = 150

End Sub

Private Sub Command2_Click() '暂停演示

Timer1.Enabled = False

End Sub

Private Sub Command3_Click()

End

End Sub

## 应用九：绘制正弦曲线

### 实例说明

在多媒体教学时，经常需要动态地画出各种曲线进行教学演示，以加深学生对知识的理解。本实例实现的是动态绘制一个正弦曲线。运行程序，单击“演示”按钮，系统将自动绘制正弦曲线，单击“停止”按钮，则停止绘制，效果如图 13 所示。

图 13 绘制正弦曲线

### 思路与技术

在模块中声明相应的 API 函数，然后在 Timer 控件中调用相关的 API 函数完成绘制正弦曲线的功能。通过调整 Timer 控件的 Interval 属性值可以控制绘制正弦曲线的速度。

程序中首先利用 API 函数 SetPixelV 给绘制的正弦曲线设置一个颜色值，然后通过 MoveToEx 和 LineTo 两个 API 函数来完成绘制正弦曲线的功能。

SetPixelV 函数的功能及声明如下。

函数功能：在指定的设备场景中设置一个像素的 RGB 值。

函数声明：

Public Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

参数说明：

l hdc 一个设备场景的句柄。

l x，y 要设置的点，用逻辑坐标表示。

l crColor 指定像素的新 RGB 颜色值。

MoveToEx 函数的功能及声明如下。

函数功能：为指定的设备场景指定一个新的当前画笔位置。原先的画笔位置被保存在 lpPoint 中。

函数声明：

Public Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long

参数说明：

l hdc 指向一个设备场景的句柄。

l x，y 采用逻辑坐标表示的新画笔位置。

l lpPoint 用于保存前一个画笔的位置。可以为 NULL（将参数改为 ByVal As Long，可以传递一个空参数）。

LineTo 函数的功能及声明如下。

函数功能：用当前画笔画一条线，从当前位置连接到一个指定的点。这个函数调用完毕，当前位置变成指定点。

函数声明：

Public Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

参数说明：

l hdc 设备场景的句柄。

l x，y 线段终点位置，采用逻辑坐标表示。这个点不会实际画出来，它不属于线段的一部分。

注意：

实例中应用的API函数比较多，限于篇幅，这里就不一一进行介绍了，请读者参阅光盘中的源代码程序。

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，设置其“名称”属性为 frmMain。

（2）选择 VB 菜单的“工程”→“添加模块”，在工程中添加一个模块，设置其“名称”属性为 Declarations。

（3）在窗体上添加一个 PictureBox 控件，用于显示绘制的正弦曲线；添加一个 Timer 控件，设置其 Enabled 属性为 False，Interval 属性为 10；添加两个 CommandButton 控件，设置其 Caption 属性分别为“演示”和“停止”。

frmMain 窗体中控件部分属性设置如表 7 所示。

表 7 frmMain 窗体中控件部分属性设置

控件名 | 属性 | 值
CoammandButton | Name Caption | Command1 演示
CoammandButton | Name Caption | Command2 停止
PictureBox | Name | Picture1
Timer | Name | Timer1

（5）为 frmMain 窗体添加如下代码。

Option Explicit

Dim MemDC As Long '内存场景

Dim hBitmap As Long '位图场景

Dim hPen As Long '画笔句柄

Dim ScreenW As Long, ScreenH As Long '

Dim H As Long, W As Long

Private Sub Command1_Click()

Timer1.Enabled = True

End Sub

Private Sub Command2_Click()

Timer1.Enabled = False

End Sub

Private Sub Form_Load()

QueryPerformanceFrequency Freq

Dim S As Currency, E As Currency 'S=开始时间, E=结束时间

QueryPerformanceCounter S

Me.Left = (Screen.Width - Me.Width) / 2

Me.Top = (Screen.Height - Me.Height) / 2

ScreenW = Screen.Width / Screen.TwipsPerPixelX

ScreenH = Screen.Height / Screen.TwipsPerPixelY

H = Picture1.ScaleHeight

W = Picture1.ScaleWidth

Picture1.AutoRedraw = True

MemDC = CreateCompatibleDC(0) '创建一个 DC

If MemDC = 0 Then MsgBox "Couldn't create MemDC"

hBitmap = CreateCompatibleBitmap(Picture1.hdc, ScreenW, H)

If hBitmap = 0 Then

MsgBox "Couldn't create hBitmap"

DeleteDC MemDC

DeleteObject hBitmap

End If

SelectObject MemDC, hBitmap

hPen = CreatePen(0, 0, vbYellow)

If hPen = 0 Then MsgBox "Couldn't create hPen"

SelectObject MemDC, hPen

SetBkColor MemDC, vbBlack

QueryPerformanceCounter E '结束过程

Timing "Form Load", 1000 * (CDbl(E) - CDbl(S)) / CDbl(Freq)

End Sub

Private Sub Form_Unload(Cancel As Integer)

DeleteDC MemDC

DeleteObject hBitmap

DeleteObject hPen

End Sub

Private Sub Timer1_Timer()

Dim S As Currency, E As Currency

QueryPerformanceCounter S

Dim Y As Single

Static X As Long

Y = (H / 2) * Sin(1 * Rad(X) + Rad(0))

X = X + 1

If X >= 360 Then X = 0

SetPixelV MemDC, ScreenW - 2, (H / 2) - Y, vbRed

MoveToEx MemDC, 0, (H / 2), Null

LineTo MemDC, ScreenW - 2, (H / 2)

If X = 1 Or X Mod 180 = 0 Then

MoveToEx MemDC, ScreenW - 2, 0, Null

LineTo MemDC, ScreenW - 2, H

End If

BitBlt MemDC, -1, 0, ScreenW, H, MemDC, 0, 0, SRCCOPY

BitBlt Picture1.hdc, W - ScreenW, 0, ScreenW, H, MemDC, 0, 0, SRCCOPY

Picture1.Refresh

QueryPerformanceCounter E

Timing "Timer Tick", 1000 * (CDbl(E) - CDbl(S)) / CDbl(Freq)

End Sub

Function Rad(ByVal Degrees As Long) As Double

Dim S As Currency, E As Currency

QueryPerformanceCounter S

Const pi As Double = 3.14159265358979

Rad = Degrees * pi / 180

QueryPerformanceCounter E

Timing "Rad", 1000 * (CDbl(E) - CDbl(S)) / CDbl(Freq)

End Function

（6）为 Declarations 模块添加如下代码

Option Explicit

Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long

Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long

Public Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Public Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long

Public 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

Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

Public Const SRCCOPY = &HCC0020

Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long

Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

Public Freq As Currency

Dim Total1 As Double, Total2 As Double, Total3 As Double, Total4 As Double

Dim Average1 As Double, Average2 As Double, Average3 As Double, Average4 As Double

Dim CallCount1 As Double, CallCount2 As Double, CallCount3 As Double, CallCount4 As Double

Sub Timing(Procedure As String, Time As Double)

Select Case Procedure

Case "Timer Tick"

Total1 = Total1 + Time

CallCount1 = CallCount1 + 1

Average1 = Round(Total1 / CallCount1, 3)

Case "Form Load"

Total2 = Total2 + Time

CallCount2 = CallCount2 + 1

Average2 = Round(Total2 / CallCount2, 3)

Case "Rad"

Total3 = Total3 + Time

CallCount3 = CallCount3 + 1

Average3 = Round(Total3 / CallCount3, 3)

Case "Resize"

Total4 = Total4 + Time

CallCount4 = CallCount4 + 1

Average4 = Round(Total4 / CallCount4, 3)

End Select

End Sub

## 应用十：万花筒

万花筒可以显示出各种各样的图案，这里介绍在 VB 中设置实现具有万花筒效果的图案。这里主要利用 Line 函数和 Timer 控件，在窗体上用随机的颜色绘制出随机的图形。

最终效果如图 14 所示。

图 14 万花筒

程序代码如下：

★★★★★ Form1 ★★★★★★

Option Explicit

Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long

Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long

Public Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Public Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long

Public 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

Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

Public Const SRCCOPY = &HCC0020

Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long

Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

Public Freq As Currency

Dim Total1 As Double, Total2 As Double, Total3 As Double, Total4 As Double

Dim Average1 As Double, Average2 As Double, Average3 As Double, Average4 As Double

Dim CallCount1 As Double, CallCount2 As Double, CallCount3 As Double, CallCount4 As Double

Sub Timing(Procedure As String, Time As Double)

Select Case Procedure

Case "Timer Tick"

Total1 = Total1 + Time

CallCount1 = CallCount1 + 1

Average1 = Round(Total1 / CallCount1, 3)

Case "Form Load"

Total2 = Total2 + Time

CallCount2 = CallCount2 + 1

Average2 = Round(Total2 / CallCount2, 3)

Case "Rad"

Total3 = Total3 + Time

CallCount3 = CallCount3 + 1

Average3 = Round(Total3 / CallCount3, 3)

Case "Resize"

Total4 = Total4 + Time

CallCount4 = CallCount4 + 1

Average4 = Round(Total4 / CallCount4, 3)

End Select

End Sub

Option Explicit

Dim R1 As Integer '大圆半径

Dim R2 As Integer '小圆半径

Dim S As Integer '小圆上任意一点到圆心的距离

Const PI = 3.1415926

Dim Xt, Yt, W, H As Long 'Xt,Yt 定义为小圆上一点座标,W,H 大圆圆心座标

Dim a1, a2 As Long 'a1 定义为大圆角度，a2 定义为小圆角度

Dim TempX, TempY As Long

Private Sub Form_Load()

R1 = 2400

R2 = 700

W = Me.Width / 2 - 10

H = Me.Height / 2 - 10

Me.Cls

R1 = 2400

R2 = 700

S = 340

W = Me.Width / 2

H = Me.Height / 2

Randomize

Me.ForeColor = Int(65535 * Rnd + 1)

TempX = W - (R1 - R2 + S)

TempY = H

End Sub

Private Sub Timer1_Timer()

On Error Resume Next

Dim i As Integer

Me.Cls

Randomize

Me.ForeColor = Int(65535 * Rnd + 1)

R2 = (R1 - 10) * Rnd '循环增量

S = (R2 - 2) * Rnd

TempX = W - (R1 - R2 + S)

TempY = H

For i = 1 To 20000

a1 = (PI / 360) * i

a2 = (R1 / R2) * a1

Xt = -(R1 - R2) * Cos(a1) - S * Cos(a2 - a1) + W

Yt = (R1 - R2) * Sin(a1) - S * Sin(a2 - a1) + H

Me.Line (TempX, TempY)-(Xt, Yt)

TempX = Xt

TempY = Yt

Next i

If R2 + 10 > R1 Then Me.Cls '清空

End Sub