Visual Basic 案例集锦

案 例 集 锦
在前面的章节中讲述了使用VB创建数据库应用程序的几个范例，其实作为编程语言来说，VB易于掌握和提高，可以极为迅速和简 洁的创建Windows应用程序，非常适合普通的用户来编写符合自己需要的实用小程序。在接下来的内容中将向读者介绍几个用VB开发实用小程序的方法，并 且结合实例向读者介绍VB编程中的许多技巧。
案例一　我的桌面小闹钟
一、概述
在本例中将创建一个可以自动跟随鼠标移动的小闹钟，实时地显示当前计算机的时间，并且允许用户添加、删除和修改定时任务，这些任务将被保存在一个Access数据库中，在设置的时间到达时，闹钟将用音乐警报，并弹出消息框来提示用户。其功能模块图如图1.1所示。

图1.1　系统的功能模块图

二、数据库的准备
通过Access或者VB可视化数据管理器创建一个Access数据库，在其中添加一个名为“任务列表”的数据表。该数据表的结构如表1.1所示。

表1.1　“任务列表”数据表的结构
字段名称 任务编号 任务时间 任务内容 任务状态
字段类型 文本 文本 文本 文本
字段大小 15 15 100 10
主键 是 否 否 否

三、应用程序的编写
在VB中创建一个新的“标准EXE”工程，将其命名为“我的小闹钟”。
在工程默认的窗体Form1中添加一个图片控件，两个标签控件，一个时间控件，依表11.2至表11.5所示的内容设置窗体和控件的属性。

表1.2　窗体Form1的属性
名称 BorderStyle ShowInTaskBar
Form1 0-None False

表1.3　图片控件的属性
名称 Appearance BackColor BorderStyle
Picture1 0-Flat &H00FF8080& 1-FixedSingle

表1.4　标签控件的属性
名称 Alignment BackStyle BorderStyle Caption ForeColor
Label1Label2 2-Center2-Center 0-Transparent0-Transparent 0-None0-None 我的小闹钟00:00:00 &H00FFFFFF&&H80000012&

表1.5　时间控件的属性
名称 Enable Interval
Timer1 True 100

在控件箱窗体的空白部分右键单击，在弹出的菜单中选择“部件”，将打开“部件”对话框，如图1.2所示。

 
图1.2　“部件”对话框

在“部件”对话框中选择“控件”选项卡，在其列表中找到“Microsoft Multimedia Control 6.0”，在其前方的复选框中打勾，单击“确定”按钮，向工程中添加对Mutimedia MCI控件的引用。在控件箱的最后将出现Mutimedia MCI控件的图标，选中其图标，在Form1中绘出其实例，如图1.3所示，其属性将在代码中设置。
 
图1.3　添加Mutimedia MCI控件的Form1

在工程中添加一个普通窗体Form2，如表1.7和表1.8所示为其设置属性并添加菜单。

表1.7　窗体Form2的属性
名称 BorderStyle Caption ShowInTaskBar
Form2 1-FixedSingle 任务列表 True

表1.8　窗体Form2的菜单
标题 名称 复选 缩进等级
菜单编辑任务列表跟随鼠标退出 mnuMainmnuRWmnuGSmnuQuit 不选中不选中选中不选中 无缩进缩进缩进缩进

在窗体上添加一个框架控件，两个标签控件，一个文本框控件和4个按钮控件，并且同添加Mutimedia MCI控件一样，在窗体中添加MaskedEdit控件、ADO Data控件和DataGrid控件并创建其实例。按照表1.9至表1.15所示内容设置这些控件的属性。

表1.9　框架控件的属性
名称 Caption
Frame2 任务

表1.10　标签控件的属性
名称 Alignment Caption
Label1Label2 0-Left Justfiy0-Left Justfiy 闹响时间：任务内容：

表1.11　文本框控件的属性
名称 Text
Text1 请输入任务内容

 

表1.12　按钮控件的属性
名称 Caption
Command1 新增任务
Command2Command3Command4 删除任务修改任务关闭

表1.13　 MaskedEdit的属性
名称 Format Mask PromptChar
MaskEdBox1 hh:mm AM/PM 99:99 _

表1.14　 ADO Data控件的属性
名称 Alignment Visible
Adodc1 2-vbAlignBottom False

表1.15  DataGrid控件的属性
名称 AllowAddNew AllowDelect AllowUpdate Caption DataSource
DataGrid1 False False False 任务列表 Adodc1

完成后的窗体Form2如图1.4所示。
 
图1.4　完成后的窗体Form2
四、程序的代码详解
本例中的代码主要 功能有3个：界面控制、数据库控制和闹铃控制。其中界面控制主要的内容为控制窗体的显示和移动；数据库控制的主要内容是任务的添加、删除、编辑和保存；闹 铃控制的主要内容为显示当前时间并同任务的时间比较，在设置的时间闹铃。下面将结合程序的界面介绍程序的内容和功能。
1．主模块的代码
在工程中添加一个模块，将其命名为Mdl_Main，其主要功能为声明函数和全局变量。在模块中添加以下的代码：

Declare Function SetWindowPos Lib "user32" (ByVal H%, ByVal hb%, ByVal X%, ByVal Y%, ByVal cx%, ByVal cy%, ByVal F%) As Integer 
'声明API函数，功能是设置窗口的位置
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 
'声明API函数，功能是得到当前鼠标的位置，以像素为单位
Public Type POINTAPI   '声明用户变量类型，用于传递鼠标位置
X As Long     '鼠标的X坐标
   Y As Long     '鼠标的Y坐标
End Type
Public Oldx As Long    '旧窗体的X坐标
Public Oldy As Long    '旧窗体的Y坐标
Public Newx As Long    '新窗体的X坐标
Public Newy As Long    '新窗体的Y坐标
Public Pnt As POINTAPI   '声明变量，用于传递鼠标位置
Public GS As Boolean   '声明变量，指明是否窗体跟随鼠标移动
Public constr As String   '声明变量，传递数据库连接字符串
Public Type Alarmtype   '声明变量类型，用于传递任务的设置
    AlarmHour As Integer  '任务时间的小时部分
    AlarmMin As Integer   '任务时间的分钟部分
    alarm As Boolean    '是否闹铃
    alarmRW As String   '任务的内容
End Type
Public alarmTime( ) As Alarmtype '声明变量，用于传递任务的设置
Public noalarm As Boolean   '声明变量，指明是否需要闹铃
Public musicname As String   '声明变量，传递音乐文件名称

Public Sub Main( )     '启动过程
constr = "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source=" & App.Path & "\databases\任务列表97.mdb;"     '设置数据库连接字符串
musicname = App.Path & "\music\alarmmusic.mid"  '设置音乐文件名称
Form1.Show       '显示闹钟窗体
End Sub

Public Sub GetAlarmtime( )   '得到任务列表的函数
If Form2.Adodc1.Recordset.RecordCount <> 0 Then '有任务时
noalarm = False          '闹响为开
ReDim alarmTime(1 To Form2.Adodc1.Recordset.RecordCount) 
'重设任务列表数组长度
Form2.Adodc1.Recordset.MoveFirst     '移动至最前记录
For i = 1 To Form2.Adodc1.Recordset.RecordCount '循环设置
'设置任务列表的内容
alarmTime(i).AlarmHour = Hour(Form2.Adodc1.Recordset(1)) 
alarmTime(i).AlarmMin = Minute(Form2.Adodc1.Recordset(1))
If Form2.Adodc1.Recordset(3) = "已执行" Then
alarmTime(i).alarm = False
Else
alarmTime(i).alarm = True
End If
alarmTime(i).alarmRW = Form2.Adodc1.Recordset(2)
Form2.Adodc1.Recordset.MoveNext '移动至下一个记录
Next i
Else
noalarm = True  '没有任务时无需闹响
End If
End Sub
2. 窗体Form1的代码 
窗体Form1的代码如下:

Dim HourNow As Integer    '声明窗体级变量，表示当前小时
Dim MinNow As Integer    '声明窗体级变量，表示当前分钟
Dim alarmID As Integer    '声明窗体级变量，表示触发的任务序号

Private Sub Form_Load( )   '窗体加载
GS = True       '初始设置窗体为跟随鼠标
Me.Height = Picture1.Height   '设置窗体高度
Me.Width = Picture1.Width   '设置窗体宽度
Call SetWindowPos(Me.hWnd, -1, 0, 0, 0, 0, 3) '设置窗体为最上层
'以下设置MCI控件
MMControl1.Notify = False   '多媒体命令执行完毕不返回Done事件
MMControl1.Wait = False    '让程序在多媒体命令完成前就得到控制权
MMControl1.Shareable = False  '媒体设备不共享
MMControl1.FileName = musicname  '设置闹响播放的音乐名称
MMControl1.Command = "Open"   '打开设备
Call GetAlarmtime     '设置初始的任务列表
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) MMControl1. Command = "Close" '窗体卸载前关闭多媒体设备，释放资源
End Sub

'在标签控件上单击鼠标时
Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
If Button = 2 Then     '右键单击
Form1.PopupMenu Form2.mnuMain  '显示窗体Form2的菜单
End If
End Sub

'在标签控件上单击鼠标时
Private Sub Label2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then     '右键单击
Form1.PopupMenu Form2.mnuMain   '显示窗体Form2的菜单
End If
End Sub

'在标签控件上单击鼠标时
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
If Button = 2 Then     '右键单击
Form1.PopupMenu Form2.mnuMain  '显示窗体Form2的菜单
End If
End Sub

'在标签控件上单击鼠标时
Private Sub Picture2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
If Button = 2 Then     '右键单击
Form1.PopupMenu Form2.mnuMain  '显示窗体Form2的菜单
End If
End Sub

Private Sub Timer1_Timer( )   '时间控件的代码
Label2.Caption = Time    '显示当前时间
HourNow = Hour(Time)    '获得当前时间的小时
MinNow = Minute(Time)    '获得当前时间的分钟
'检查任务列表，决定是否闹铃
If Form2.Visible = False And noalarm = False Then 
For i = 1 To Form2.Adodc1.Recordset.RecordCount  '逐项对比
If HourNow = alarmTime(i).AlarmHour And MinNow = alarmTime(i).AlarmMin And alarmTime(i).alarm = True Then '时间正好
alarmID = i       '传递任务序号
Call alarm       '调用闹响过程
Exit Sub
End If
Next i
End If
'窗体跟随的代码
If GS = True And Form2.Visible = False Then  '需要跟随
GetCursorPos Pnt     '得到鼠标位置
Oldx = Form1.Left     '将窗体位置传递给变量
Oldy = Form1.Top
Newx = Pnt.X * Screen.TwipsPerPixelX '得到窗体的新位置，数据由像素转为缇
Newy = Pnt.Y * Screen.TwipsPerPixelY
incx = (Newx - Oldx) / 80 * Screen.TwipsPerPixelX + 10  '计算偏移量
incy = (Newy - Oldy) / 80 * Screen.TwipsPerPixelY
Form1.Move Oldx + incx, Oldy + incy      '移动窗体
End If
End Sub

Public Sub alarm( )           '闹响过程
MMControl1.Command = "play"         '播放音乐
MsgBox "您有任务！" & CStr(HourNow) & "时" & CStr(MinNow) & "分，" & alarmTime(alarmID).alarmRW, vbInformation + vbOKOnly, "提醒" 
'显示消息
alarmTime(alarmID).alarm = False       '设置已闹铃
MMControl1.Command = "Stop"    '停止闹铃音乐
'修改数据库中的记录
Form2.Adodc1.Recordset.Move alarmID - 1, 1 
Form2.Adodc1.Recordset(3) = "已执行"
End Sub
3. 窗体Form2的代码
窗体Form2的代码主要功能为数据操作，以下为窗体Form2的代码：

Private Sub Form_Load( )     '加载窗体
'设置数据源
Adodc1.ConnectionString = constr
Adodc1.RecordSource = "select * from 任务列表 order by 任务时间"
Adodc1.Refresh
'设置当前任务
If Not Adodc1.Recordset.RecordCount = 0 Then
Adodc1.Recordset.MoveFirst
MaskEdBox1.Text = Adodc1.Recordset(1)
Text1.Text = Adodc1.Recordset(2)
End If
End Sub

Private Sub Command1_Click()    '新增任务按钮
If Command1.Caption = "新增任务" Then  '新增任务
    MaskEdBox1.SetFocus      '格式文本框得到焦点
    Text1.Text = "请输入任务内容"
    Command1.Caption = "保存"
    Command2.Enabled = False
    Command3.Enabled = False
    Command4.Caption = "取消"
    Adodc1.Recordset.AddNew     '添加记录
Else
If Text1.Text <> "" And MaskEdBox1.Text <> MaskEdBox1.FormattedText Then          '输入数据有效
    Command1.Caption = "新增任务"
    Command2.Enabled = True
    Command3.Enabled = True
    Command4.Caption = "关闭"
 '设置字段的值
    Adodc1.Recordset(0) = CStr(Time)
    Adodc1.Recordset(1) = MaskEdBox1.Text
    Adodc1.Recordset(2) = Text1.Text
    Adodc1.Recordset(3) = "未执行"
    Adodc1.Recordset.UpdateBatch    '保存记录
    Adodc1.Refresh
 '刷新数据
    Adodc1.RecordSource = "select * from 任务列表 order by 任务时间"
    Adodc1.Refresh
    Adodc1.Recordset.MoveFirst
    Call DataGrid1_Click
    Else
    MsgBox "输入错误！", vbOKOnly, "输入错误"
    End If
End If
End Sub

Private Sub Command2_Click( )    '删除按钮
If MsgBox("确实删除当前任务吗？", vbYesNo + vbQuestion, "确认删除") = vbYes Then
    Adodc1.Recordset.Delete     '删除记录
    Adodc1.Recordset.MoveNext
    If Adodc1.Recordset.EOF Then   '检查任务列表为空
        If Adodc1.Recordset.RecordCount = 0 Then
If MsgBox("当前列表中没有任务。添加任务吗？", vbQuestion + vbYesNo, "添加任务？") = vbYes Then
                Call Command1_Click   '添加记录
            End If
            Exit Sub
        End If
        Adodc1.Recordset.MoveFirst
    End If
    Call DataGrid1_Click
End If
End Sub

Private Sub Command3_Click( )    '修改任务按钮
If Command3.Caption = "修改任务" Then
    Command1.Enabled = False
    Command2.Enabled = False
    Command3.Caption = "保存修改"
    Command4.Caption = "取消"
    MaskEdBox1.SetFocus
Else '保存修改
    If Text1.Text <> "" And MaskEdBox1.Text <> MaskEdBox1.FormattedText Then
    Command1.Enabled = True
    Command2.Enabled = True
    Command3.Caption = "修改任务"
    Command4.Caption = "关闭"
 '更新数据
    Adodc1.Recordset(1) = MaskEdBox1.Text
    Adodc1.Recordset(2) = Text1.Text
    Adodc1.Recordset(3) = "未执行"
    Adodc1.Recordset.UpdateBatch    '保存修改
    Adodc1.Refresh
'刷新数据
    Adodc1.RecordSource = "select * from 任务列表 order by 任务时间"
    Adodc1.Refresh
    Adodc1.Recordset.MoveFirst
    Call DataGrid1_Click
    Else
    MsgBox "输入错误！", vbOKOnly, "输入错误"
    End If
End If
End Sub

Private Sub Command4_Click()  '关闭按钮
If Command4.Caption = "关闭" Then '关闭窗口
Unload Me
Else '取消修改
Command1.Enabled = True
Command2.Enabled = True
Command3.Enabled = True
Command4.Enabled = True
Command1.Caption = "新增任务"
Command2.Caption = "删除任务"
Command3.Caption = "修改任务"
Command4.Caption = "关闭"
Adodc1.Recordset.CancelBatch adAffectAllChapters '取消修改
Adodc1.Recordset.MoveFirst
Call DataGrid1_Click
End If
End Sub

Private Sub DataGrid1_Click( )      '移动当前的任务
If Not Adodc1.Recordset.RecordCount = 0 Then
MaskEdBox1.Text = Adodc1.Recordset(1)
Text1.Text = Adodc1.Recordset(2)
End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call GetAlarmtime         '刷新任务列表
End Sub

Private Sub mnuGS_Click( )       '跟随菜单
GS = Not GS 
mnuGS.Checked = GS
End Sub

Private Sub mnuQuit_Click( )      '退出菜单
'卸在所有窗体，结束程序的一种方法
For Each Form In Forms
Unload Form
Next Form
End Sub

Private Sub mnuRW_Click( )       '显示任务窗体
Form2.Left = (Screen.Width - Form2.Width) / 2
Form2.Top = (Screen.Height - Form2.Height) / 3
Form1.Left = Form2.Left - Form1.Width
Form1.Top = Form2.Top
Form2.Show
If Adodc1.Recordset.RecordCount = 0 Then
If MsgBox("当前列表中没有任务。添加任务吗？", vbQuestion + vbYesNo, "添加任务？") = vbYes Then
  Call Command1_Click
End If
Exit Sub
End If
End Sub

五、程序的运行结果
 在运行工程之前，需要将工程的启动对象设为SubMain，并且在工程所在目录的music子目录中添加一个名为alarmmusic.mid的MIDI文件。单击F5功能键启动工程。
 如图1.5所示为运行中的闹钟窗体。窗体将实时地显示当前时刻，并且跟随鼠标在窗体中移动。在窗体的任何部分右键单击，将弹出如图1.6所示的快捷菜单。

 
图1.5 运行中的闹钟窗体

 
图1.6　在闹钟窗体上右键单击弹出的快捷菜单

 在菜单中选择“跟随鼠标”命令，使其不被选中，则闹钟窗体将停在屏幕中，不再跟随鼠标移动。重新选中“跟随鼠标”，则会恢复跟随状态。
 在菜单中选择“任务列表”命令，将显示任务窗体，如图1.7所示。可以在该窗体中编辑任务列表，设置后的任务列表如图1.8所示。
 
图1.7　运行中的任务列表窗体
 
图1.8　运行中的任务列表

 当到达设置时刻时，程序将播放闹铃音乐，并显示提示窗口，如图1.9所示，单击“确定”按钮后可以结束闹铃状态，任务列表中相应的记录将被显示为“已执行”。
 选择菜单中的“退出”命令将结束程序。
 
图1.9　闹铃响时的提醒信息

小结
本例调用了VB中附带的Multimedia MCI控件、MaskedBox控件等非标准控件和VB编程的高级技巧——API函数，并且结合数据库等其他技巧，创建了一个有创意且十分实用的闹钟程 序，显示了VB在编写Windows应用程序的优点。希望读者可以从中有所收获。

案例二　我的日记本
一、概述
 本节将设计一个具有Windows XP界面风格，名为“我的日记本”的应用程序。这是一个以Access数据库为基础的小巧的日记本程序，通过ADO数据控件和其相应的数据操作，实现新 建、查找、修改和删除日记等操作。通过一些并不复杂的技巧的应用，本例实现了对Windows XP界面的仿真，大大美化了应用程序的界面，使软件的吸引力倍增。

二、数据库的设计
 使用Microsoft Access创建一个Access数据库，命名为“我的日记本97.mdb”，保存于本例所在目录的databases子目录中。在数据库中增加一个数据表，名为“日记本”，用于保存本例中的数据。该数据表的结构如表2.1所示。
 
表2.1　日记本数据表的结构
字段名称 日期 天气 心情 内容
字段类型 日期/时间 文本 文本 备注
字段大小 短日期 20 20 
主键 是 否 否 否

 保存数据库和数据表，数据库的设计和创建工作完成。
三、应用程序界面设计
 本例将创建一个Windows XP的仿真窗体，并在该窗体上实现所有的操作。完成后的窗体界面如图2.1所示。

 
图2.1　设计完毕的主窗体
 以下是窗体的详细建立过程：
(1) 在VB中新建一个“标准EXE”工程，命名为“我的日记本”。
(2) 选中工程默认的窗体Form1，将其BorderStyle属性设置为“0-None”，即无边框窗体，并将其ShowInTaskBar属性设置为“True”，即在任务栏中显示，该窗体将作为整个系统界面的基础。
(3) 在绘图软件中打开事先准备好的Windows XP窗体轮廓的图片，如图2.2所示，将其复制至剪贴板中。返回VB窗口，选中窗体Form1，右键单击该窗体，在快捷菜单中选择“粘贴”命令，将其Picture属性设置为选定的图像。调整其窗体大小至适合图片。
(4) 在窗体上添加两个图片框控件Picture1和Picture2，用于作为其他控件的容器。如表2.2所示设置这两个图片框控件的属性。此时窗体如图2.3所示。

表2.2　图片框控件的属性
名称 Appearance BackColor BorderStyle
Picture1Picture2 0-Flat0-Flat &H00FFC0C0&&H00FFC0C0& 1-FixedSingle0-None

 
图2.2　Windows XP窗体轮廓的图片

 
图2.3　添加图片框控件后的窗体

(5) 在Picture1中添加3个标签控件、一个日期控件DTPicker1、一个文本框控件Text1和一个组合框Combo1控件，用于显示数据。在 Picture2中添加两个图片框控件和一个框架控件，作为下一步将添加的控制按钮的容器。在窗体上添加一个RichTextBox控件 RichTextBox1，用于显示日记的正文。这些控件的属性设置如下表2.3至表2.5所示。此时的窗体界面如图2.4所示。

表2.3　日期控件的属性
名称 CheckBox Format UpDown
DTPicker1 False 1-dtpShortDate False

表2.4　图片框控件的属性
名称 Appearance BackColor BorderStyle Index
PicBoxPicBox 0-Flat0-Flat &H00FFC0C0&&H00FFC0C0& 1-FixedSingle1-FixedSingle 01

表2.5　框架控件的属性
名称 Appearance BackColor BorderStyle Caption
Frame1 0-Flat &H00FFC0C0& 1-FixedSingle 消息

 
图2.4　添加数据显示控件后的窗体

(6) 在窗体上添加9个图像控件，用于保存程序中需要的三种按钮的图片，这些图片的说明如表2.6所示。此时的窗体如图2.5所示。

 
图2.5　在窗体上添加图像控件

表2.6　图像控件的属性和说明
名称 BorderStyle Index 图片说明
ImageButton1ImageButton1ImageButton1ImageButton2ImageButton2ImageButton2ImageButton3ImageButton3ImageButton3 0- None0-None0-None0-None0-None0-None0-None0-None0-None 012012012 普通按钮正常状态普 通按钮焦点状态普通按钮按下状态标题按钮正常状态标题按钮焦点状态标题按钮按下状态关闭按钮正常状态关闭按钮焦点状态关闭按钮按下状态

(7) 在PicBox(0)和PicBox(1)中添加8个图片框控件，并在这8个图片框控件中添加8个标签按钮，从而实现用图片框来模拟按钮，这些控件的属性 如表2.7所示。在窗体中添加一个ADO数据控件，作为整个程序的数据源，其属性将有代码来设置。设置好的窗体如图2.6所示。

表2.7　控件的属性
标签控件名称 Index BackStyle Caption 所在图片框
Label5Label4Label4Label5Label4Label4Label4Label4 00112345 0- Transparent0-Transparent0-Transparent0-Transparent0-Transparent0- Transparent0-Transparent0-Transparent 我想写新日记保存新日记取消保存我要查旧日记修改日记删除日记保存修改取 消修 改 Pictitle(0)Picbutton(0)Picbutton(1)Pictitle(1)Picbutton(2)Picbutton(3)Picbutton(4)Picbutton(5)

 
图2.6　在窗体中添加图片框模拟按钮

 对窗体中的控件调整大小和布局，即可完成窗体界面的设计。

四、程序的代码
 本例的代码分为两个部分，窗体Form1的代码和模块的代码。其中模块的代码主要功能为创建不规则窗口，以下是两部分的代码。
1．窗体Form1的代码
Dim moveform As Boolean  '声明变量，窗体是否移动
Dim mouseX As Long   '声明变量，鼠标的X坐标
Dim mouseY As Long   '声明变量，鼠标的Y坐标
Dim newDiary As Boolean  '声明变量，是否正在编辑新日记
Dim OpenDiary As Boolean '声明变量，是否有日记文件打开

Private Sub Form_Load( )
Call ShapeForm(Me, RGB(255, 0, 255))  '调用过程，创建不规则窗口
'声明数据源
Adodc1.ConnectionString = "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source=" & App.Path & "\databases\我的日记本97.mdb;"
Adodc1.RecordSource = "select 日期,天气,心情,内容 from 日记表 Order by 日期"
Adodc1.Refresh
'变量的初始赋值
moveform = False
newDiary = False
OpenDiary = False
'设置控件的属性
LblMessage.Caption = "    欢迎使用！！！！！"
Text1.Locked = True
Combo1.Locked = True
RichTextBox1.Locked = True
For i = 1 To 1050
PicBox(0).Height = PicBox(0).Height - 1
Next i
For i = 1 To 2000
PicBox(1).Height = PicBox(1).Height - 1
Next i
End Sub

Private Sub DTPicker1_Change( )    '日期控件内容改变时
If newDiary = True Then      '编辑新日记
    Exit Sub         '退出过程
Else          '查找日记
If Adodc1.Recordset.RecordCount <> 0 Then '存在日记文件时
'搜索日记
Adodc1.Recordset.MoveFirst
Adodc1.Recordset.Find "日期 = " & CStr(DTPicker1.Value)
If Adodc1.Recordset.EOF Then    '未找到日记
    Beep
    LblMessage.Caption = "未找到相应记录"
    DTPicker1.Value = Date
    Text1.Text = ""
    Combo1.Text = ""
    RichTextBox1.Text = ""
 Else '找到了日记
    LblMessage.Caption = "找到了！费了我好大的劲…"  '显示信息
    DTPicker1.Value = Adodc1.Recordset(0)   '显示数据
    Text1.Text = Adodc1.Recordset(1)    '显示数据
    Combo1.Text = Adodc1.Recordset(2)    '显示数据
    RichTextBox1.Text = Adodc1.Recordset(3)   '显示数据
    OpenDiary = True         '设置变量
    End If 
Else            '不存在任何日记
    Beep
    LblMessage.Caption = "没有日记存在！"
End If
End If
End Sub

'在窗体上按下鼠标按钮时
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
If Button = 1 Then      '如果是鼠标左键
    moveform = True      '设置变量
    mouseX = X       '得到当前鼠标位置
    mouseY = Y 
End If
End Sub

'在窗体上移动鼠标时
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
If moveform Then      '如果是移动窗口（鼠标按钮按下）
'计算新的窗体坐标值
CurrX = Me.Left - mouseX + X
CurrY = Me.Top - mouseY + Y
'移动窗体到新的位置
Me.Move CurrX, CurrY
Else  '不是移动窗口 
PicClose.Picture = Imagebutton3(0).Picture   '设置关闭按钮的图片
End If
End Sub

'在窗体上抬起鼠标按钮
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
moveform = False      '设置变量
End Sub

Private Sub Label4_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call PicButton_MouseDown(Index, Button, Shift, X, Y)
End Sub

Private Sub Label4_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call PicButton_MouseMove(Index, Button, Shift, X, Y)
End Sub

Private Sub Label4_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call PicButton_MouseUp(Index, Button, Shift, X, Y)
End Sub

Private Sub Label5_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call PicTitle_MouseDown(Index, Button, Shift, X, Y)
End Sub

Private Sub Label5_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call PicTitle_MouseMove(Index, Button, Shift, X, Y)
End Sub

Private Sub Label5_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call PicTitle_MouseUp(Index, Button, Shift, X, Y)
End Sub

Private Sub PicBox_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)    '在控件数组上移动鼠标
'设置图片
PicTitle(0).Picture = ImageButton2(0).Picture 
PicTitle(1).Picture = ImageButton2(0).Picture
For i = 0 To 5
PicButton(i).Picture = ImageButton1(0).Picture
Next i
End Sub

Private Sub PicButton_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'设置图片
PicButton(Index).Picture = ImageButton1(2)
End Sub

Private Sub PicButton_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'设置图片
If Button = 1 Then
PicButton(Index).Picture = ImageButton1(2)
Else
PicButton(Index).Picture = ImageButton1(1)
End If
End Sub

Private Sub PicButton_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'设置图片
PicButton(Index).Picture = ImageButton1(0)
'执行操作
Select Case Index
    Case 0 '保存新日记
         If newDiary = True Then
  '检查是否已存在日记
         If Adodc1.Recordset.RecordCount <> 0 Then
         Adodc1.Recordset.MoveFirst
         End If
         Adodc1.Recordset.Find "日期 = " & CStr(DTPicker1.Value)
         If Not Adodc1.Recordset.EOF Then  '当天日记已存在
         Beep
         LblMessage.Caption = "    当天的日记已经存在!"
         Exit Sub
         End If
  '当天日记不存在，添加记录
           Adodc1.Recordset.AddNew
           Adodc1.Recordset(0) = DTPicker1.Value
           Adodc1.Recordset(1) = Text1.Text
       　 Adodc1.Recordset(2) = Combo1.Text
     Adodc1.Recordset(3) = RichTextBox1.Text
  Adodc1.Recordset.UpdateBatch adAffectAllChapters
         LblMessage.Caption = "    保存日记成功！"
           newDiary = False
         Text1.Locked = True
         Combo1.Locked = True
          RichTextBox1.Locked = True
OpenDiary = True
           Else  '没有新建日记
              Beep
              LblMessage.Caption = "    没有事请别乱点！添乱！"
          End If
      Case 1        '取消新日记
          If newDiary = True Then   '存在新日记
              Adodc1.Recordset.CancelBatch adAffectAllChapters
              LblMessage.Caption = "    已经取消新日记！"
              newDiary = False
              DTPicker1.Value = Date
              Text1.Text = ""
              Combo1.Text = ""
              RichTextBox1.Text = ""
              Text1.Locked = True
              Combo1.Locked = True
              RichTextBox1.Locked = True
          Else       '不存在新日记
              Beep
              LblMessage.Caption = "    没有事请别乱点！添乱！"
          End If
      Case 2 '修改日记
          If OpenDiary = False Then
          LblMessage.Caption = "没有打开任何日记！"
          Exit Sub
          Else
          Text1.Locked = False
          Combo1.Locked = False
          RichTextBox1.Locked = False
          LblMessage.Caption = "现在可以修改日记了！"
          End If
      Case 3 '删除日记
          If OpenDiary = False Then
          LblMessage.Caption = "没有打开任何日记！"
          Exit Sub
          Else
          Adodc1.Recordset.Delete
          Adodc1.Refresh
          LblMessage.Caption = "    删除日记成功！"
          OpenDiary = False
          End If
Case 4 '保存修改
          If OpenDiary = False Then
          LblMessage.Caption = "没有打开任何日记！"
Exit Sub
          Else
          Adodc1.Recordset(0) = DTPicker1.Value
          Adodc1.Recordset(1) = Text1.Text
          Adodc1.Recordset(2) = Combo1.Text
          Adodc1.Recordset(3) = RichTextBox1.Text
          Adodc1.Recordset.UpdateBatch adAffectAllChapters
          LblMessage.Caption = "    保存修改日记成功！"
          End If
      Case 5 '取消修改
          If OpenDiary = False Then
          LblMessage.Caption = "没有打开任何日记！"
          Exit Sub
          Else
          LblMessage.Caption = "    已经取消修改日记！"
          Text1.Locked = True
          Combo1.Locked = True
          RichTextBox1.Locked = True
          End If
      End Select
End Sub

Private Sub PicClose_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'设置图片
PicClose.Picture = Imagebutton3(2).Picture
End Sub

Private Sub PicClose_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'设置图片
If Button = 1 Then
PicClose.Picture = Imagebutton3(2).Picture
Else
PicClose.Picture = Imagebutton3(1).Picture
End If
End Sub

Private Sub PicClose_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'设置图片
PicClose.Picture = Imagebutton3(0).Picture
'执行动作
If newDiary = True Then
LblMessage.Caption = "    当前日记没有保存！请您保存修改或者取消修改。"
Exit Sub
Else
Unload Me
End If
End Sub

Private Sub PicTitle_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'设置图片
PicTitle(Index).Picture = ImageButton2(2).Picture
End Sub
 
Private Sub PicTitle_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'设置图片
If Button = 1 Then
PicTitle(Index).Picture = ImageButton2(2).Picture
Else
PicTitle(Index).Picture = ImageButton2(1).Picture
End If
End Sub

Private Sub PicTitle_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'设置图片
PicTitle(Index).Picture = ImageButton2(0).Picture
'执行动作
Select Case Index
      Case 0 '新建日记
If newDiary = True Then
       Beep
       LblMessage.Caption = "    当前还有未保存的日记！"
       Exit Sub
       End If
       If PicBox(0).Height < 500 Then    '弹出列表
       For i = 1 To 1050
       PicBox(0).Height = PicBox(0).Height + 1
       Next i
       End If
       If PicBox(1).Height > 500 Then    '缩回列表
       For i = 1 To 2000
       PicBox(1).Height = PicBox(1).Height - 1
       Next i
End If
'添加日记
       newDiary = True
      Text1.Locked = False
      Combo1.Locked = False
     RichTextBox1.Locked = False
       LblMessage.Caption = "    准备开动写日记！"
       DTPicker1.Value = Date
       Text1.Text = "天气如何?"
       Combo1.Text = "心情好吗?"
       RichTextBox1.Text = "   今天要写什么呢？告诉我啊！"
       Case 1 '查找日记
       If newDiary = True Then
       Beep
    LblMessage.Caption = "当前还有未保存的日记！"
       Exit Sub
       End If
       If PicBox(0).Height > 500 Then     '收回列表
      For i = 1 To 1050
       PicBox(0).Height = PicBox(0).Height - 1
       Next i
       End If
       If PicBox(1).Height < 500 Then     '弹出列表
       For i = 1 To 2000
       PicBox(1).Height = PicBox(1).Height + 1
       Next i
       End If
       LblMessage.Caption = "请在日期栏中选择日期。"
       End Select
End Sub
2. 模块的代码
 在工程中添加一个模块，命名为Mdl_shapeform。其代码为：

Public Declare Function GetPixel Lib "Gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long   'API函数，得到像素的颜色
Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long  
' API函数，设置窗体边界
Public Declare Function CreateRectRgn Lib "Gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long 
' API函数，生成对象边界
Public Declare Function CombineRgn Lib "Gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long 'API函数，合并边界
Public Declare Function DeleteObject Lib "Gdi32" (ByVal hObject As Long) As Long           'API函数，删除对象
Dim CurRgn, TempRgn As Long       ' 声明窗体边界变量

Public Function ShapeForm(bg As Form, transColor)
    Dim X, Y As Integer
CurRgn = CreateRectRgn(0, 0, bg.ScaleWidth, bg.ScaleHeight) 
'以当前窗体的边界为范围生成初始边界
    While Y <= 5        ' 对每行的像素进行检查
        While X <= bg.ScaleWidth     ' 遍历每个像素
            If GetPixel(bg.hdc, X, Y) = transColor Then 
  ' 如果像素的颜色是屏蔽色
                TempRgn = CreateRectRgn(X, Y, X + 1, Y + 1) 
' 以透明点创建区域
' 将透明点从初始边界中去除
                success = CombineRgn(CurRgn, CurRgn, TempRgn, RGN_DIFF) 
                DeleteObject (TempRgn)    ' 释放资源
            End If
            X = X + 1
        Wend
            Y = Y + 1
            X = 0
    Wend
    success = SetWindowRgn(bg.hWnd, CurRgn, True)    ' 设置窗体的边界
    DeleteObject (CurRgn)          ' 释放资源
End Function

五、程序的运行结果
 在VB中按下F5功能键运行当前工程。图2.7所示为运行中的窗体Form1，请读者注意通过对模块中过程的调用，窗体Form1的左上角和右上角均为圆角，即实现了不规则窗体。

 
图2.7　运行初始的窗体

 单击“我想写新日记”按钮，对应的列表将展开，显现“保存新日记”和“取消保存”按钮，同时各个数据显示控件的内容均会变为有关的问候语。如图2.8所示。

 
图2.8　“添加新日记”的操作界面

 日记写入完毕后，可以单击“保存新日记”按钮保存，也可以单击“取消保存”按钮来取消添加。系统将根据不同的操作给予提示。单击“我要查旧日记” 按钮，对应的列表将打开，而“我要写新日记”对应的列表会关闭。系统显示提示信息“请在日期栏中选择日期”，如图2.9所示。在日期栏中选择日期，程序将 在数据库中查找相应的记录，如果不存在相应记录，则给出错误信息，反之则显示数据，如图2.10所示。
 在查找到旧日记后，可以单击“修改日记”进入修改状态，修改完毕可以选择“保存修改”或者“取消修改”，也可以删除当前的日记。
 单击窗体上的关闭按钮，如果还有未被保存的日记，则会出现提示信息；反之，则退出系统。

 
图2.9　查询日记的界面

 
图2.20　查找到记录的界面

小结
 在本例中向读者介绍了使用各种图形控件和对鼠标的不同事件进行编程，从而实现特殊窗体效果的方法，并且介绍了使用API函数创建不规则窗体的方法。仔细研究这些代码和方法，对于读者更好的了解VB以及提高编程能力都会有很大的帮助。

案例三　Access数据库简单报表的创建
一、概述
本案例将创建一个简单数据报表，该报表使用数据环境设计器作为数据源。数据环境 设计器使用和 Visual Basic一起提供的NorthWind数据库（Access数据库）创建一个简单的层次结构游标。该游标包含Customers、Orders、 Order Details和Products等4个表，并使用表与表之间的相关字段进行表的链接。完成的数据环境设计结构图如图3.1和图3.2所示。
最后完成的报表结构图如图3.3所示。
在 开始逐步处理之前，确保计算机上存在Northwind数据库（Nwind.mdb）。如果Microsoft Visual Studio的安装路径为D:\Microsoft Visual Studio，则该数据库应该在D:\Microsoft Visual Studio\VB98下。如果不存在，从Visual Basic CD复制一份文件到计算机的硬盘上。
 

图3.1　数据环境设计结构示意图（一）         图3.2　数据环境设计结构示意图（二）

 
图3.3　报表结构示意图
二、单层次结构报表
首先介绍的是利用“CustomerID”字段链接表Customers和Orders，从而创建一个单层次结构游标，其具体步骤如下：
(1) 创建一个新的“标准 EXE”工程；
(2) 在“工程”菜单上，选择“添加数据环境”命令，向工程中添加一个数据环境设计器；
(3) 右键单击“Connection1”图标，选择“属性”命令，弹出“数据链接属性”对话框，如图3.4所示；
 
图3.4　“数据链接属性”对话框
(4) 在“数据链接属性”对话框上单击“Microsoft Jet 3.51 OLE DB Provider”，这是为访问Jet数据库选择正确的OLE DB供应商；
(5) 单击“下一步”按钮进入“连接”选项卡，单击第一个文本框旁边的按钮，打开“选择 Access 数据库”对话框，搜索到 nwind.mdb 文件，它安装在D:\Microsoft Visual Studio\VB98目录下，单击“确定”按钮关闭对话框；
(6) 右键单击“Connection1”图标，单击“重命名”，把图标名改为“”；
(7) 右键单击“Northwind”图标，然后单击“添加命令”显示“Command1” 图标。右键单击“Command1”图标，选择“属性”命令，弹出“Command1属性”对话框，如图3.5所示；
 
    图3.5　“Command1属性”对话框
(8) 参照表3.1所示各个数据设置“Command1属性”对话框中相应属性的属性值，单击“确定”结束对话框。

表3.1　“Command1属性”属性表
属性 属性值
Command NameConnectionDataBase ObjectObject Name CustomersNorthwindTableCustomers

(9) 右键单击“Customers”图标，然后单击“Add Child Command”显示“Command1” 图标；右键单击“Command1”图标，选择“Properties”，弹出“Command1属性”对话框；
(10) 参照表3.2所示数据设置“Command1属性”对话框中相应属性的属性值；

表3.2　“Command1属性”属性表
属性 属性值
Command NameDataBase ObjectObject Name OrdersTableOrders

(11) 选择“Relation”选项卡，单击“Add”按钮，这样通过“CustomerID”字段将表Customers和Orders链接起来了，其结果如图3.6所示；

 
图3.6　表链接的创建

(12) 单击“确定”按钮结束对话框；
(13) 参照表3.3所示数据设置工程和设计器的属性；

 

表3.3　工程和设计器的属性表
对象 属性 属性值
Project1DataEnvironment1Form1 NameNameName PrjNwindDeNwindFrmShowReport
(14) 保存工程。
创建了数据环境设计器后，下面就可以创建一个数据报表。因为并不是数据环境中所有的字段在一个数据报表中都有用，所以创建的报表可能只显示几个字段。创建一个新的数据报表只包含“客户的订单日期”，其具体步骤如下：
(1) 在“工程”菜单上，选择“添加 Data Report”命令，向工程中添加一个报表设计器；
(2) 根据表3.4所示设置DataReport1对象的属性；

表3.4　DataReport1的属性表
属性 属性值
NameCaption RptNwindNorthwind Data Report

(3) “属性”窗口上，单击“数据源（DataSource）”，然后单击“DeNwind”。然后单击“数据成员（DataMember）”并单击“Customers”；
(4) 右键单击数据报表设计器，单击“Retrieve Structure”，并单击“确定”按钮；
(5) 从数据环境设计器中把“CompanyName”字段（在“Customers”命令下）拖到数据报表设计器Group Header（Customers_Header）部分；
(6) 删除名为“Label1”的 Label 控件（rptLabel）；
(7) 从数据环境设计器中把“OrderDate”字段（在Orders命令下）拖到数据报表设计器Detail（Orders_Detail）部分，并删除Label控件；
(8) 重新调整数据报表设计器部分的大小，使之如图3.7所示；
 
图3.7　数据报表设计图
(9) 保存工程。
下面将介绍两种方法来显示报表。
一是利用代码调用rptNwind窗体，其步骤如下：
(1) 在窗体frmShowReport中添加控件Command1；
(2) 将其“Name”属性改为“CmdShow”，“Caption”属