# Type 语句应用方案

## 知识概述

为了方便对数据类型的描述，用户在定义数据类型时，可以使用 Visual Basic 中的一个或多个标准数据类型，也可以使用一个或多个用户先前声明的自定义类型来定义新的数据类型。自定义数据类型通过 Type 语句进行定义，其语法格式如下：

[Private | Public] Type varname

elementname [([subscripts])] As type

[elementname [([subscripts])] As type]

…

End Type

Type 语句的语法包含以下参数，如表 1 所示。

表 1 Type 语句中的参数说明

参 数 | 描 述
Public | 可选的。用于声明可在所有工程的所有模块的任何过程中使用的用户定义类型
Private | 可选的。用于声明只能在包含该声明的模块中使用的用户自定义的类型
varname | 必需的。用户自定义类型的名称；遵循标准的变量命名约定
elementname | 必需的。用户自定义类型的元素名称。除了可以使用的关键字，元素名称也应遵循标准变量命名约定
subscripts | 可选的。数组元素的维数。当定义大小可变的数组时，只需圆括号。subscripts 参数使用如下语法： [lower To] upper [,[lower To] upper] … 如果不显式指定 lower，则数组的下界由 Option Base 语句控制。如果没有 Option Base 语句，则下界为 0
type | 必需的。元素的数据类型；可以是 Byte、Boolean、Integer、Long、Currency、Single、Double、Decimal（目前尚不支持）、Date、String（对变长的字符串）、String * length（对定长的字符串）、Object、Variant、其他的用户自定义的类型或对象类型

例如，定义一个变量名为 ygxx 的自定义变量，代码如下：

Type ygxx

YgName As String '字符串类型

YgSex As Boolean '布尔型

YgBirth As Date '日期型

End Type

自定义数据类型的使用方法与其他数据类型的使用方法基本相同。

示例

完整程序代码：

程序运行结果如图 1 所示。

图 1 Type 语句运行结果

form1 窗体中的代码：

Option Explicit

Private Sub Command1_Click()

Dim a As People

a.Name = "王五"

a.Age = 23

a.Tel = "15423"

Debug.Print a.Name, a.Age, a.Tel

End Sub

模块中的代码：

Option Explicit

Type People

Name As String * 10

Age As Integer

Tel As String * 20

End Type

注意：在 Type...End Type 块中不允许使用行号和行标签。

## 应用一：使用随机文件保存员工工资

随机文件可以应用在工程文件中的很多方面，如利用随机文件保存学生成绩、员工工资，还可以利用随机文件开发各种智力游戏等等。下面我们就介绍一下如何利用随机文件来保存员工的工资。在如图 1 所示的利用随机文件保存职工工资信息界面中，当输入完员工的职工证号、姓名和工资等信息后，单击“添加”按钮，即可将所输入的信息保存到随机文件“随机文件.bat”当中。

图 1 利用随机文件保存职工工资信息

单击“添加”按钮的部分事件代码如下：

Private Sub Command3_Click()

……

Open App.Path & "\随机文件.dat" For Random As #1 Len = Len(Recordvar)

total = LOF(1) / Len(Recordvar)

position = total + 1

Put #1, position, Recordvar

Close #1

……

End Sub

程序完整代码如下：

Private Type employee

id As String * 3

name As String * 8

unit As String * 8

age As Integer

salary As Integer

End Type

Dim Recordvar As employee

Dim msgStr As String

Private Sub Command1_Click()

Dim total As Integer

Dim age As Single

List1.Clear

Open App.Path & "\随机文件.txt" For Random As #1 Len = Len(Recordvar)

total = LOF(1) / Len(Recordvar)

For n = 1 To total

Get #1, n, Recordvar

msgStr = Recordvar.id & " " & Recordvar.name & " " & Recordvar.age & " " & Recordvar.unit & " " & Recordvar.salary

List1.AddItem msgStr

Next n

Close #1

End Sub

Private Sub Command2_Click()

Text1.Text = ""

Text2.Text = ""

Text3.Text = ""

Text4.Text = ""

Text5.Text = ""

Command3.Enabled = True

Text1.SetFocus

End Sub

Private Sub Command3_Click()

Dim total As Integer

If Text1.Text = "" Or Text2.Text = "" Or Text3.Text = "" Or Text4.Text = "" Or Text5.Text = "" Then

MsgBox "输入数据不完整，请输入完整数据"

Text1.SetFocus

Exit Sub

End If

With Recordvar

.id = Text1.Text

.name = Text2.Text

.age = Text3.Text

.unit = Text4.Text

.salary = Text5.Text

End With

Open App.Path & "\随机文件.txt" For Random As #1 Len = Len(Recordvar)

total = LOF(1) / Len(Recordvar)

position = total + 1

Put #1, position, Recordvar

Close #1

Call Command1_Click

Command3.Enabled = False

End Sub

Private Sub Command4_Click()

Unload Me

End Sub

Private Sub Form_Load()

Text1.Text = ""

Text2.Text = ""

Text3.Text = ""

Text4.Text = ""

Text5.Text = ""

Command4.Enabled = False

List1.Clear

End Sub

Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)

If KeyCode = 13 Then

Text2.SetFocus

Else

End If

End Sub

Private Sub Text2_KeyDown(KeyCode As Integer, Shift As Integer)

If KeyCode = 13 Then

Text3.SetFocus

Else

End If

End Sub

Private Sub Text3_KeyDown(KeyCode As Integer, Shift As Integer)

If KeyCode = 13 Then

Text4.SetFocus

Else

End If

End Sub

Private Sub Text4_KeyDown(KeyCode As Integer, Shift As Integer)

If KeyCode = 13 Then

Text5.SetFocus

Else

End If

End Sub

## 应用二：定时登录 Internet

### 实例说明

本实例通过在应用程序中设置时间来实现定时启动 IE 浏览网页的功能，如图 1 所示，当程序启动时，如果已经连接到 Internet，则在设置时间的日期控件中设置登录网页的时间，然后，单击“确定”按钮，完成设置，此时，等到当前系统的时间与所设置的日期时间相同时，即可自动启动 IE，自动登录到网址为 www.mingrisoft.com 的网页中。

图 1 定时登录 Internet

### 思路与技术

在 Timer 控件中，判断当前系统时间与所设置的时间是否相等，然后，再通过 API 函数 RasGetConnectStatus 判断当前是否连接到 Internet 上，如果连接到 Internet，则通过 API 函数 ShellExecute 启动 IE，浏览网页。

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

函数功能：获取 Internet 的连接状态。

函数声明：

Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long

参数说明：

l lpRasCon Internet 连接句柄。

l lpcConnections 返回 Internet 连接状态。

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，默认名为 Form1， BorderStyle 属性设置为 1-Fixed Single，MinButton 属性设置为 True。

（2）在窗体上添加 1 个 Frame 控件，名称取默认值，Caption 属性设置为空。

（3） 打开“工程”菜单下的“部件”子菜单，在弹出的“部件”对话框中添加 Microsoft Windows Common Control-2 6.0 控件。

（4）在 Frame 控件上添加一个 DTPicker 控件，名称设置为 DT1，Format 属性设置为 2-dtpTime。

（5）在 Frame 控件上添加 3 个 Label 控件和 2 个 TextBox 控件。

（6）在窗体上添加 1 个 Timer 控件，设置 Timer1 控件的 Enable 属性为“False”，Interval 属性值设置为 800。

（7）在窗体上添加 2 个 CommandButton 控件，名称取默认值，Caption 属性分别为“确定”和“退出”。

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

控件名 | 属性 | 值
CommandButton | Name Caption | Command1 退出
CommandButton | Name Caption | Command2 确定
DTPicker | Name | DT1
Frame | Name | Frame1
Label | Name Caption | Label1 设置每天 登录 Internet
Label | Name Caption | Label3 登录网址：
Label | Name Caption | Label5 网络状态：
Label | Name | Label4
TextBox | Name | Text1
TextBox | Name | Text2
Timer | Name | Timer1

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

Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias _

"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _

ByVal lpFile As String, ByVal lpParameters As String, _

ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias _

"RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, _

lpcConnections As Long) As Long

Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias _

"RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long

Const SW_SHOW = 5

Const RAS95_MaxEntryName = 256

Const RAS95_MaxDeviceType = 16

Const RAS95_MaxDeviceName = 32

Private Type RASCONNSTATUS95

dwSize As Long

RasConnState As Long

dwError As Long

szDeviceType(RAS95_MaxDeviceType) As Byte

szDeviceName(RAS95_MaxDeviceName) As Byte

End Type

Private Type RASCONN95

dwSize As Long

hRasCon As Long

szEntryName(RAS95_MaxEntryName) As Byte

szDeviceType(RAS95_MaxDeviceType) As Byte

szDeviceName(RAS95_MaxDeviceName) As Byte

End Type

Dim TimeStr1 As String

Dim TimeStr2 As String

Private Sub Command2_Click()

Timer1.Enabled = True

Open (App.Path & "\UserSet.ini") For Output As #1

Print #1, DT1.Value

Close #1

MsgBox "设置完成!", 64, "提示信息"

End Sub

Private Sub Form_Load()

Dim Intext

Open (App.Path & "\UserSet.ini") For Input As #1

Do While Not EOF(1)

Line Input #1, Intext

DT1.Value = Intext

Loop

Close #1

End Sub

Private Sub Form_Unload(Cancel As Integer)

Open (App.Path & "\UserSet.ini") For Output As #1

Print #1, DT1.Value

Close #1

End Sub

Private Sub Timer1_Timer() '根据 Internet 链接状态，启动 ie 浏览器

Dim TRasCon(255) As RASCONN95

Dim lg As Long

Dim lp As Long

Dim RetVal As Long

Dim status As RASCONNSTATUS95

TimeStr1 = Mid(DT1.Value, 12, Len(DT1.Value))

TimeStr2 = Time

If TimeStr1 = TimeStr2 Then

TRasCon(0).dwSize = 412

lg = 256 * TRasCon(0).dwSize

RetVal = RasEnumConnections(TRasCon(0), lg, lp) '判断是否连接到 Internet

If RetVal <> 0 Then '如果没有拨号连接

Exit Sub

End If

status.dwSize = 160

RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, status)

If status.RasConnState = &H2000 Then '如果已经链接 Internet

ShellExecute 0&, vbNullString, Text1.Text, vbNullString, vbNullString, 0 '调用 ie

Else

End If

End If

If status.RasConnState = &H2000 Then '如果已经链接 Internet

Text2.Text = "已经连接到 Internet!"

Else

Text2.Text = "未连接 Internet!"

End If

End Sub

Private Sub Command1_Click()

End

End Sub

## 应用三：根据网络连接控制 IE 启动

### 实例说明

本实例实现当程序运行时，如果没有连接到 Internet，则弹出如图 1 所示的提示信息；如果连接到 Internet，则弹出如图 2 所示的窗口，单击窗口上的“启动”按钮，将登录到文本框中所设置的网址的网页中。

图 1 没有连接到 Internet

图 2 根据网络连接控制 IE 启动

### 思路与技术

利用 RasGetConnectStatus 函数判断是否连接 Internet，如果连接 Internet，则使用 ShellExecute 函数启动 IE 浏览器。

其中，RasGetConnectStatus 函数是获取 Internet 连接状态的。

RasGetConnectStatus：获取 Internet 连接状态。

声明函数：

Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA"_

(lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long

参数说明：

l lpRasCon Internet 连接句柄。

l lpcConnections 返回 Internet 连接状态。

l 返回值 如果函数调用成功，则返回零。否则，返回非零错误值。

### 开发步骤

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

（2）在窗体上添加一个 Frame 控件，名称取默认值，Caption 属性设置为空。

（3）在 Frame 控件上添加一个 Label 控件和一个 TextBox 控件。

（4）在窗体上添加两个 CommandButton 控件，名称取默认值，Caption 属性分别设置为“启动”和“退出”。

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

控件名 | 属性 | 值
CommandButton | Name Caption | Command1 退出
CommandButton | Name Caption | Command2 启动
Frame | Name | Frame1
Label | Name Caption | Label3 登录网址：
Label | Name | Label4
TextBox | Name Text | Text1 www.mingrisoft.com
Timer | Name | Timer1

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

Option Explicit

Dim TRasCon(255) As RASCONN95

Dim lg As Long

Dim lp As Long

Dim RetVal As Long

Dim status As RASCONNSTATUS95

Private Declare Function ShellExecute Lib "shell32.dll" Alias _

"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _

ByVal lpFile As String, ByVal lpParameters As String, _

ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias _

"RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, _

lpcConnections As Long) As Long

Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias _

"RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long

Const SW_SHOW = 5

Const RAS95_MaxEntryName = 256

Const RAS95_MaxDeviceType = 16

Const RAS95_MaxDeviceName = 32

Private Type RASCONNSTATUS95

dwSize As Long

RasConnState As Long

dwError As Long

szDeviceType(RAS95_MaxDeviceType) As Byte

szDeviceName(RAS95_MaxDeviceName) As Byte

End Type

Private Type RASCONN95

dwSize As Long

hRasCon As Long

szEntryName(RAS95_MaxEntryName) As Byte

szDeviceType(RAS95_MaxDeviceType) As Byte

szDeviceName(RAS95_MaxDeviceName) As Byte

End Type

Dim TimeStr1 As String

Dim TimeStr2 As String

Private Sub Command2_Click()

RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, status)

If status.RasConnState = &H2000 Then '如果已经链接 Internet

ShellExecute 0&, vbNullString, Text1.Text, vbNullString, vbNullString, 0 '调用 ie

Else

End If

End Sub

Private Sub Form_Load()

TRasCon(0).dwSize = 412

lg = 256 * TRasCon(0).dwSize

RetVal = RasEnumConnections(TRasCon(0), lg, lp) '判断是否连接到 Internet

If status.RasConnState = &H2000 Then '如果已经链接 Internet

MsgBox "已经连接到 Internet!", , "提示信息"

Else

MsgBox "未连接 Internet,请检查网络连接是否正常", , "提示信息"

End

End If

End Sub

Private Sub Command1_Click()

End

End Sub

## 应用四：实现关机、重启计算机

### 实例说明

有时在安装应用程序中需要实现关闭或重启计算机的功能。本实例将介绍这一功能是如何实现的。程序运行之后，通过单击窗体中的控制按钮就可以重新启动、关闭或者注销计算机，如图 1 所示。

图 1 关机、重启计算机

### 思路与技术

通过 API 函数 GetCurrentProcess、LookupPrivilegeValue、AdjustTokenPrivileges 和 OpenProcessToken 来实现控制计算机关闭或重启的功能。

GetCurrentProcess 函数的声明如下：

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

LookupPrivilegeValue 函数的声明如下：

Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long

AdjustTokenPrivileges 函数的声明如下：

Private Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long

OpenProcessToken 函数的声明如下：

Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long

实现关机的关键代码如下：

ExitWindowsEx EWX_FORCE Or EWX_SHUTDOWN, 0

实现重启计算机的关键代码如下：

ExitWindowsEx EWX_REBOOT, 0

实现注销计算机的关键代码如下：

ExitWindowsEx EWX_LOGOFF, 0

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，将其 Caption 属性设置为“实现关机与重启动计算机”。

（2）在窗体添加 4 个 CommandButton 控件，将其 Caption 属性分别设置为“重新启动计算机”、“关闭计算机”、“注销计算机”和“退出”。

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

控件名 | 属性 | 值
CommandButton | Name Caption | Command1 重新启动计算机
CommandButton | Name Caption | Command2 关闭计算机
CommandButton | Name Caption | Command3 注销计算机
CommandButton | Name Caption | Command4 退出

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

Option Explicit

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long

Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long

Private Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long

Const TOKEN_ADJUST_PRIVILEGES = &H20

Const TOKEN_QUERY = &H8

Const SE_PRIVILEGE_ENABLED = &H2

Private Type LUID

UsedPart As Long

IgnoredForNowHigh32BitPart As Long

End Type

Private Type TOKEN_PRIVILEGES

PrivilegeCount As Long

TheLuid As LUID

Attributes As Long

End Type

Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long

Const HELP_CONTENTS = &H3&

Const EWX_WAIT = 16

Const EWX_REBOOT = 2 '重起

Const EWX_LOGOFF = 0 '注销

Const EWX_FORCE = 4 '终止没有响应的进程

Const EWX_SHUTDOWN = 8 '关闭电源

Private Sub Command1_Click()

'重新启动计算机

ExitWindowsEx EWX_REBOOT, 0

End Sub

Private Sub Command2_Click()

'关闭计算机

ExitWindowsEx EWX_FORCE Or EWX_SHUTDOWN, 0

End Sub

Private Sub Command3_Click()

End

End Sub

Private Sub Command4_Click()

ExitWindowsEx EWX_LOGOFF, 0

End Sub

Private Sub Form_Load()

Dim hProcessHandle As Long

Dim hTokenHandle As Long

Dim tmpLuid As LUID

Dim tkpNew As TOKEN_PRIVILEGES

Dim tkpPrevious As TOKEN_PRIVILEGES

Dim lBufferNeeded As Long

'获取当前进程的一个伪句柄

hProcessHandle = GetCurrentProcess()

OpenProcessToken hProcessHandle, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hTokenHandle

LookupPrivilegeValue "", "SeShutdownPrivilege", tmpLuid

tkpNew.PrivilegeCount = 1

tkpNew.TheLuid = tmpLuid

tkpNew.Attributes = SE_PRIVILEGE_ENABLED

lBufferNeeded = 0

'允许当前应用程序有关闭操作系统的权限

AdjustTokenPrivileges hTokenHandle, False, tkpNew, Len(tkpPrevious), tkpPrevious, lBufferNeeded

End Sub

## 应用五：短信息服务（frmAC_QQ 窗体）完整程序代码

短信息服务如图 1 所示。

图 1 短信息服务

Option Explicit

'局域网发送消息

Private Declare Function NetMessageBufferSend Lib "NETAPI32.DLL" (Server As Any, yToName As Byte, yFromName As Any, yMsg As Byte, ByVal lSize As Long) As Long

Dim FName As String * 256

'移动窗体

Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const WM_NCLBUTTONDOWN = &HA1

Private Const HTCAPTION = 2

Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) As Long

Private Declare Function WNetEnumResource Lib "mpr.dll" Alias "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, lpBuffer As Any, lpBufferSize As Long) As Long

Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (lpTo As Any, lpFrom As Any, ByVal lLen As Long)

Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long

Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long

Private Const RESOURCE_GLOBALNET As Long = &H2& ' 枚举所有资源

' 网络资源类型常数

Private Const RESOURCEDISPLAYTYPE_DIRECTORY& = &H9

Private Const RESOURCEDISPLAYTYPE_DOMAIN& = &H1

Private Const RESOURCEDISPLAYTYPE_FILE& = &H4

Private Const RESOURCEDISPLAYTYPE_GENERIC& = &H0

Private Const RESOURCEDISPLAYTYPE_GROUP& = &H5

Private Const RESOURCEDISPLAYTYPE_NETWORK& = &H6

Private Const RESOURCEDISPLAYTYPE_ROOT& = &H7

Private Const RESOURCEDISPLAYTYPE_SERVER& = &H2

Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3

Private Const RESOURCEDISPLAYTYPE_SHAREADMIN& = &H8

Private Const RESOURCETYPE_ANY As Long = &H0&

Private Const RESOURCETYPE_DISK As Long = &H1&

Private Const RESOURCETYPE_PRINT As Long = &H2&

Private Const RESOURCETYPE_UNKNOWN As Long = &HFFFF&

Private Const RESOURCEUSAGE_ALL As Long = &H0&

Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&

Private Const RESOURCEUSAGE_CONTAINER As Long = &H2&

Private Const RESOURCEUSAGE_RESERVED As Long = &H80000000

Private Const NO_ERROR = 0

Private Const ERROR_MORE_DATA = 234

Private Const RESOURCE_ENUM_ALL As Long = &HFFFF

' 枚举信息数据类型

Private Type NETRESOURCE

dwScope As Long ' 枚举的范围

dwType As Long ' 枚举的类型

dwDisplayType As Long ' 资源的类型

dwUsage As Long ' 枚举的用法

sLocalName As String ' 由本地系统引用的资源名称

sRemoteName As String ' 资源的网络名

sComment As String ' 由网络供应商设置

sProvider As String ' 网络供应商的名字

End Type

' 自定义类型存放枚举信息

Private Type NETRESOURCE_BUF

dwScope As Long ' 枚举的范围

dwType As Long ' 枚举的类型

dwDisplayType As Long ' 资源的类型

dwUsage As Long ' 枚举的用法

pLocalName As Long ' 由本地系统引用的资源名称

pRemoteName As Long ' 资源的网络名

pComment As Long ' 由网络供应商设置

pProvider As Long ' 网络供应商的名字

End Type

Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long

Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long

Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long

Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

' Socket 错误常数和版本常数

Private Const SOCKET_ERROR As Long = -1

Private Const MAX_WSADescription = 256

Private Const MAX_WSASYSStatus = 128

Private Const ERROR_SUCCESS As Long = 0

Private Const WS_VERSION_REQD As Long = &H101

Private Const MIN_SOCKETS_REQD As Long = 1

Private Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&

Private Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&

' 存放主机信息的结构

Private Type HOSTENT

hName As Long ' 主机的正式名称

hAliases As Long ' 主机别名列表

hAddrType As Integer ' 主机地址类型

hLen As Integer ' 主机地址长度

hAddrList As Long ' 主机 IP 地址列表

End Type

' 存放 Winsock 版本等信息的结构

Private Type WSADATA

wVersion As Integer

wHighVersion As Integer

szDescription(0 To MAX_WSADescription) As Byte

szSystemStatus(0 To MAX_WSASYSStatus) As Byte

wMaxSockets As Integer

wMaxUDPDG As Integer

dwVendorInfo As Long

End Type

' 初始化 Socket

Private Function SocketsInitialize(Optional sErr As String) As Boolean

Dim WSAD As WSADATA

Dim sLoByte As String

Dim sHiByte As String

' 初始化 Winsock DLL，并判断版本是否满足要求

If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then

sErr = "The 32-bit Windows Socket is not responding."

SocketsInitialize = False

Exit Function

End If

' 判断是否有支持足够的 Socket

If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then

sErr = "This application requires a minimum of " & _

CStr(MIN_SOCKETS_REQD) & " supported sockets."

SocketsInitialize = False

Exit Function

End If

' 判断 Winsock 的版本是否被 32 为 Winsock 支持

If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _

(LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _

HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then

sHiByte = CStr(HiByte(WSAD.wVersion))

sLoByte = CStr(LoByte(WSAD.wVersion))

sErr = "Sockets version " & sLoByte & "." & sHiByte & _

" is not supported by 32-bit Windows Sockets."

SocketsInitialize = False

Exit Function

End If

SocketsInitialize = True

End Function

' 释放 Socket 库所占用的系统资源

Private Sub SocketsCleanup()

If WSACleanup() <> ERROR_SUCCESS Then

App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError

End If

End Sub

' 获得一个整数的高字节位

Private Function HiByte(ByVal wParam As Integer)

HiByte = wParam \ &H1 And &HFF&

End Function

' 获得一个整数的低字节位

Private Function LoByte(ByVal wParam As Integer)

LoByte = wParam And &HFF&

End Function

' 用于获得网上邻居计算机名称的子程序

Sub GetNeighbor()

Const MAX_RESOURCES = 256

Const NOT_A_CONTAINER = -1

Dim bFirstTime As Boolean

Dim lReturn As Long

Dim hEnum As Long

Dim lCount As Long

Dim lMin As Long

Dim lLength As Long

Dim l As Long

Dim lBufferSize As Long

Dim lLastIndex As Long

Dim uNetApi(0 To MAX_RESOURCES) As NETRESOURCE_BUF

Dim uNet() As NETRESOURCE

bFirstTime = True

Do

If bFirstTime Then

' 启动对顶级网络资源进行枚举的过程,并返回枚举资源所用的句柄

lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, hEnum)

bFirstTime = False

Else

' 如果 uNet(lLastIndex)资源包含了可以枚举的额外资源,并返回枚举资源所用的句柄

If uNet(lLastIndex).dwUsage And RESOURCEUSAGE_CONTAINER Then

' 启动对包含于指定资源内的资源的枚举

lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, uNet(lLastIndex), hEnum)

Else '否则

lReturn = NOT_A_CONTAINER

hEnum = 0

End If

' 下一个资源

lLastIndex = lLastIndex + 1

End If

If lReturn = NO_ERROR Then '如果返回值表示成功

lCount = RESOURCE_ENUM_ALL

Do

' 设置缓冲区大小

lBufferSize = UBound(uNetApi) * Len(uNetApi(0)) / 2

'应用上面 WNetOpenEnum 返回的句柄枚举网络资源,并将枚举信息装载到 uNetApi 缓冲区

lReturn = WNetEnumResource(hEnum, lCount, uNetApi(0), lBufferSize)

If lCount > 0 Then

' 为动态数组变量重新分配存储空间

ReDim Preserve uNet(0 To lMin + lCount - 1) As NETRESOURCE

For l = 0 To lCount - 1

'将枚举信息赋值给 uNet

uNet(lMin + l).dwScope = uNetApi(l).dwScope

uNet(lMin + l).dwType = uNetApi(l).dwType

uNet(lMin + l).dwDisplayType = uNetApi(l).dwDisplayType

uNet(lMin + l).dwUsage = uNetApi(l).dwUsage

' 对于以下的值通过内存复制的方式赋值

If uNetApi(l).pLocalName Then

lLength = lstrlen(uNetApi(l).pLocalName)

uNet(lMin + l).sLocalName = Space$(lLength)

CopyMem ByVal uNet(lMin + l).sLocalName, ByVal uNetApi(l).pLocalName, lLength

End If

If uNetApi(l).pRemoteName Then

lLength = lstrlen(uNetApi(l).pRemoteName)

uNet(lMin + l).sRemoteName = Space$(lLength)

CopyMem ByVal uNet(lMin + l).sRemoteName, ByVal uNetApi(l).pRemoteName, lLength

End If

If uNetApi(l).pComment Then

lLength = lstrlen(uNetApi(l).pComment)

uNet(lMin + l).sComment = Space$(lLength)

CopyMem ByVal uNet(lMin + l).sComment, ByVal uNetApi(l).pComment, lLength

End If

If uNetApi(l).pProvider Then

lLength = lstrlen(uNetApi(l).pProvider)

uNet(lMin + l).sProvider = Space$(lLength)

CopyMem ByVal uNet(lMin + l).sProvider, ByVal uNetApi(l).pProvider, lLength

End If

Next l

End If

lMin = lMin + lCount

Loop While lReturn = ERROR_MORE_DATA

End If

If hEnum Then

' 结束枚举操作

l = WNetCloseEnum(hEnum)

End If

Loop While lLastIndex < lMin

If UBound(uNet) > 0 Then

For l = 0 To UBound(uNet)

' 判断资源类型,并将网上邻居显示出来

If uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SERVER Then

List1.AddItem uNet(l).sRemoteName

End If

Next l

End If

End Sub

Private Sub cmdClear_Click()

txtMemo.Text = ""

End Sub

Private Sub cmdSend_Click()

Dim ToName() As Byte

Dim FromName() As Byte

Dim Msg() As Byte

ToName = Trim(TxtCmpName.Text) & vbNullChar

FromName = Trim(txtFromName.Text) & vbNullChar

Msg = txtMemo.Text & vbNullChar

NetMessageBufferSend ByVal 0&, ToName(0), FromName(0), Msg(0), UBound(Msg)

End Sub

Private Sub Form_Load()

GetNeighbor

txtFromName.Text = Mid(frm_mainBefore.StatusBar1.Panels(1).Text, 6, Len(frm_mainBefore.StatusBar1.Panels(1).Text) - 5)

End Sub

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

ReleaseCapture

SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0

End Sub

Private Sub labExit_Click()

Unload Me

End Sub

Private Sub List1_Click()

TxtCmpName = Mid(List1.List(List1.ListIndex), 3, Len(List1.List(List1.ListIndex)))

End Sub

## 应用六：在任务栏中添加应用程序的图标

很多读者可能都会注意到，大多数应用程序在运行的时候，在操作系统任务栏的右下角都会显示该应用软件的图标，即常常所说的“托盘”。如常见的防火墙软件“瑞星杀毒软件 2003 版”。下面介绍一下如何在酒店管理系统当中添加程序“托盘”的功能。在酒店管理系统中，当显示系统主界面之后，在任务栏的右下角就显示酒店管理系统的图标，在关闭应用程序之后，图标自动消失。如图 1 所示。

图 1 显示应用程序图标

可以运用 ShowWindow 函数和 Shell_NotifyIcon 函数来实现在任务栏中设置图标的功能。下面是这两个函数的用法：

l ShowWindow 函数

该函数的功能是用于显示程序的当前状态。

函数声明：

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

参数：nwnd 参数，程序句柄；nCmdShow 参数，程序状态。

返回值：如果程序当前可见，返回非 0 值；如果程序当前不可见，返回值为 0。

l Shell_NotifyIcon 函数

该函数的功能是给系统发送添加、修改、删除任务栏系统图标的消息。

函数声明：

Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

参数：dwMessage 参数，消息设置值。若取消为 NIM_ADD（0），表示向托盘加入图标；若值为 NIM_MODIFY（1），表示修改托盘中的图标；若值为 NIM_DELETE（2），表示删除托盘中的图标。

若想显示应用程序的图标，需在主界面窗口中声明如下代码：

Option Explicit

Const MAX_TOOLTIP As Integer = 64

Const NIF_ICON = &H2

Const NIF_MESSAGE = &H1

Const NIF_TIP = &H4

Const NIM_ADD = &H0

Const NIM_DELETE = &H2

Const WM_MOUSEMOVE = &H200

Const WM_LBUTTONDOWN = &H201

Const WM_LBUTTONUP = &H202

Const WM_LBUTTONDBLCLK = &H203

Const WM_RBUTTONDOWN = &H204

Const WM_RBUTTONUP = &H205

Const WM_RBUTTONDBLCLK = &H206

Const SW_RESTORE = 9

Const SW_HIDE = 0

Private Type NOTIFYICONDATA

cbSize As Long

hwnd As Long

uID As Long

uFlags As Long

uCallbackMessage As Long

hIcon As Long

szTip As String * MAX_TOOLTIP

end Type

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Private nfIconData As NOTIFYICONDATA

在主界面窗体中的 Load 事件中添加下面的代码，当窗体运行的时候在程序的右下角即可显示应用程序的图标。

Private Sub Form_Load()

……

nfIconData.hwnd = Me.hwnd

nfIconData.uID = Me.Icon

nfIconData.uFlags = &H2 Or &H1 Or &H4

nfIconData.uCallbackMessage = &H200

nfIconData.hIcon = Me.Icon.Handle

nfIconData.szTip = "System Tray Example" & vbNullChar

nfIconData.cbSize = Len(nfIconData)

Call Shell_NotifyIcon(&H0, nfIconData)

……

End Sub

当关闭系统的时候，任务栏中的应用程序图标消失，请看下面的代码：

Private Sub EXIT1_Click() '关闭系统

Call Shell_NotifyIcon(NIM_DELETE, nfIconData) '删除托盘中图标

End

End Sub

## 应用七：网络计时管理在实际工程中的应用

网络计时管理在实际的工程当中经常会被用到，在现代的企事业单位中都能够上网，然而经常会因为管理上的疏忽，致使企业内部员工经常会在单位无限时的上网，并且做一些与工作无关的事，如上网聊天、玩网络游戏等。为了杜绝这种现象的发生，我们可以在计算机上运行一个网络计时管理的程序来对员工上网进行限制和管理，以便为企业减少不必要的损失。

网络计时管理另一个最重要的应用就是在网吧管理程序当中，在网吧上过网的读者都会知道，在网吧管理系统当中，为了计算上网顾客的上网时间和消费金额都有一个网络计时的管理软件。下面所介绍的就是关于网吧管理系统中网络计时模块的程序设计。当系统运行的时候，如果正在上网，程序将提示用户已经连接到 Internet 上，并且在窗体界面中显示上网用户的信息并且自动统计上网所花费的时间和上网次数等信息，当顾客下网的时候（即关闭窗口的时候）系统将会自动统计出该顾客上网所用的时间，并且根据上网时间自动计算出该顾客的上网消费金额，最后网吧管理系统程序将相应的信息保存到数据库当中；如果没有上网，程序将提示未连接到 Internet。网络计时器窗体的运行结果如图 1 所示。

图 1 网络计时器窗体的运行结果

可以利用 RasEnumConnections 函数判断网络连接的状态。如果为连接状态，再对上网次数和上网时间进行统计。

在窗体载入时，判断用户是否在网上，具体代码如下：

Private Sub Form_Load()

Dim TRasCon(255) As RASCONN95

Dim lg As Long

Dim lp As Long

Dim RetVal As Long

Dim status As RASCONNSTATUS95

DTP1.Value = Format(Now, "hh:mm:ss")

Data1.DatabaseName = App.Path & "\Data_ryxx.mdb"

Data1.RecordSource = "表 1"

'判断是否连接 Internet

TRasCon(0).dwSize = 412

lg = 256 * TRasCon(0).dwSize

RetVal = RasEnumConnections(TRasCon(0), lg, lp)

If RetVal <> 0 Then

Exit Sub

End If

status.dwSize = 160

RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, status)

If status.RasConnState = &H2000 Then

MsgBox "计时开始!"

Timer1.Enabled = True

Else

MsgBox "没有连接 Internet!"

End If

End Sub

如果用户在网上，则在 Timer 控件的 Timer 事件中记录用户上网时间和消费金额，具体代码如下：

Private Sub Timer1_Timer()

DTP2.Value = DTP3.Value - DTP1.Value

DTP2.Value = Format(DTP2.Value, "hh:mm:ss ")

temp = DTP2.Hour

temp1 = Val(Label9.Caption) * temp

Label11.Caption = "您当前上网的消费费用为 " + Str(temp1) + " 元 人民币"

End Sub

程序完整代码如下：

Option Explicit

Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias _

"RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, _

lpcConnections As Long) As Long

Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias _

"RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long

Const RAS95_MaxEntryName = 256

Const RAS95_MaxDeviceType = 16

Const RAS95_MaxDeviceName = 32

Private Type RASCONNSTATUS95

dwSize As Long

RasConnState As Long

dwError As Long

szDeviceType(RAS95_MaxDeviceType) As Byte

szDeviceName(RAS95_MaxDeviceName) As Byte

End Type

Private Type RASCONN95

dwSize As Long

hRasCon As Long

szEntryName(RAS95_MaxEntryName) As Byte

szDeviceType(RAS95_MaxDeviceType) As Byte

szDeviceName(RAS95_MaxDeviceName) As Byte

End Type

Dim i, temp, temp1 As Integer

Private Sub Form_Load()

Dim TRasCon(255) As RASCONN95

Dim lg As Long

Dim lp As Long

Dim RetVal As Long

Dim status As RASCONNSTATUS95

DTP1.Value = Format(Now, "hh:mm:ss")

Data1.DatabaseName = App.Path & "\Data_ryxx.mdb"

Data1.RecordSource = "表 1"

'判断是否连接 Internet

TRasCon(0).dwSize = 412

lg = 256 * TRasCon(0).dwSize

RetVal = RasEnumConnections(TRasCon(0), lg, lp)

If RetVal <> 0 Then

Exit Sub

End If

status.dwSize = 160

RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, status)

If status.RasConnState = &H2000 Then

MsgBox "计时开始!"

Timer1.Enabled = True

Else

MsgBox "没有连接 Internet!"

End If

End Sub

Private Sub Timer1_Timer()

DTP2.Value = DTP3.Value - DTP1.Value

DTP2.Value = Format(DTP2.Value, "hh:mm:ss ")

temp = DTP2.Hour

temp1 = Val(Label9.Caption) * temp

Label11.Caption = "您当前上网的消费费用为 " + Str(temp1) + " 元 人民币"

End Sub

Private Sub Command1_Click()

Unload Me

End Sub

Private Sub Timer2_Timer()

DTP3.Value = Now

End Sub

## 应用八：利用 Ping 工具连接网络计算机

大家都知道，在“运行”中可以“Ping”通对方的计算机，为了操作应用程序的方便，当网络不通的时候，可以在应用程序当中利用 Ping 工具来连接对方的计算机。Ping 操作是测试网络是否连通的工具，使用 Ping 操作您可以向目标计算机发送测试用的网络数据包，目标计算机如果收到会将网络数据包回传给您的计算机。如在网络答辩管理系统中，当教师答辩的服务器端与学生答辩的客户端断开连接时（指的是局域断开连接）就可以利用“网络链接维护”窗口使得两计算机取得连接。当运行程序的时候，在输入或选择对方的 IP 地址之后，然后单击“连接”按钮，即可检测对方计算机是否在网络上、在网络上的连接速度以及数据包的大小等信息。如果您输入的 IP 地址在以前没有输入过，那么系统就保留本次输入的 IP 地址信息，以便下次在“Ping”该台计算机的时候就不用输入该计算机的 IP 地址信息，直接在列表中选择就可以了，如果本次输入或选择的信息以前已经输入过，那么信息将不作任何的保留。在应用程序当中 Ping 通对方计算机如图 1 所示。

图 1 在应用程序当中 Ping 通对方计算机

网络协议当中的 ICMP（Internet Control Message Protocol 网络控制信息协议）协议功能很多，Ping 操作就是利用 ICMP 回响请求报文和回响应答报文来测试目的站点的可达性，同时也可以发送一系列的回响请求并根据捕获的响应提供丢失数据的统计。

程序完整代码如下：

（1）Form1 窗体的代码如下：

Option Explicit

Private Const WS_VERSION_REQD As Long = &H101

Private Const INADDR_NONE As Long = &HFFFFFFFF

Private Const MAX_WSADescription As Long = 256

Private Const MAX_WSASYSStatus As Long = 128

Private Const PING_TIMEOUT As Long = 500

Private Type ICMP_OPTIONS

Ttl As Byte

Tos As Byte

Flags As Byte

OptionsSize As Byte

OptionsData As Long

End Type

Private Type ICMP_ECHO_REPLY

Address As Long

status As Long

RoundTripTime As Long

DataSize As Long

DataPointer As Long

Data As String * 250

End Type

Private Type WSADATA

wVersion As Integer

wHighVersion As Integer

szDescription(0 To MAX_WSADescription) As Byte

szSystemStatus(0 To MAX_WSASYSStatus) As Byte

wMaxSockets As Long

wMaxUDPDG As Long

dwVendorInfo As Long

End Type

Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long

Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long

Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, _

ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Long, _

ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, _

ByVal Timeout As Long) As Long

Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, _

lpWSADATA As WSADATA) As Long

Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, _

ByVal dwHostLen As Long) As Long

Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _

(xDest As Any, xSource As Any, ByVal nbytes As Long)

Private Declare Function inet_addr Lib "WSOCK32.DLL" (ByVal s As String) As Long

Private Sub Combo1_Click()

Data1.Refresh

End Sub

Private Sub Command1_Click() 'ping 网络计算机

Dim ECHO As ICMP_ECHO_REPLY

Dim pos As Long

Dim success As Long

Dim WSAD As WSADATA

Dim aa As Boolean

Dim mystr As String

aa = WSAStartup(WS_VERSION_REQD, WSAD) = 0

If aa Then

Dim hPort As Long

mystr = inet_addr(Combo1.Text)

If mystr <> INADDR_NONE Then

hPort = IcmpCreateFile()

If hPort Then

Call IcmpSendEcho(hPort, mystr, Text2.Text, Len(Text2.Text), _

0, ECHO, Len(ECHO), PING_TIMEOUT) '发送回响请求报文，返回回响应答报文

Call IcmpCloseHandle(hPort)

End If

If ECHO.status = 0 Then Text3.Text = "ping 成功" Else Text3.Text = "ping 失败"

Text4.Text = ECHO.Address '显示网络计算机地址

Text5.Text = ECHO.RoundTripTime & " ms" '显示网络链接延迟时间

Text6.Text = ECHO.DataSize & " bytes 显示数据包大小"

Text7.Text = ECHO.DataPointer

End If

End If

Data1.RecordSource = "select * from 表 1 where ip='" + Combo1 + "' "

Data1.Refresh

If Data1.Recordset.RecordCount > 0 Then

Data1.RecordSource = "select * from 表 1"

Data1.Refresh

Exit Sub

Else

Data1.RecordSource = "select * from 表 1"

Data1.Refresh

Data1.Recordset.AddNew

Text1.Text = Combo1.Text

End If

End Sub

Private Sub Command2_Click()

End

End Sub

Private Sub Command3_Click()

Data1.Recordset.AddNew

End Sub

Private Sub Command4_Click()

Data1.Refresh

End Sub

Private Sub Form_Load()

Data1.DatabaseName = App.Path & "\Data_ping.mdb"

Data1.RecordSource = "表 1"

Data1.RecordSource = "select * from 表 1"

Data1.Refresh

If Data1.Recordset.NoMatch Then

Exit Sub

Else

Data1.Recordset.MoveFirst

Do While Data1.Recordset.EOF = False

Combo1.AddItem (Data1.Recordset.Fields("ip"))

Data1.Recordset.MoveNext

Loop

End If

End Sub

Private Sub Data1_Error(DataErr As Integer, Response As Integer)

'这就是放置错误处理代码的地方

'如果想忽略错误，注释掉下一行代码

'如果想捕捉错误，在这里添加错误处理代码

MsgBox "数据错误事件命中错误：" & Error$(DataErr)

Response = 0 '忽略错误

End Sub

Private Sub Data1_Reposition()

Screen.MousePointer = vbDefault

On Error Resume Next

'这将显示当前记录位置

'为动态集和快照

Data1.Caption = "记录：" & (Data1.Recordset.AbsolutePosition + 1)

'对于 Table 对象，当记录集创建后并使用下面的行时，

'必须设置 Index 属性

'Data1.Caption = "记录：" & (Data1.Recordset.RecordCount * (Data1.Recordset.PercentPosition * 0.01)) + 1

End Sub

Private Sub Data1_Validate(Action As Integer, Save As Integer)

'这是放置验证代码的地方

'当下面的动作发生时，调用这个事件

Select Case Action

Case vbDataActionMoveFirst

Case vbDataActionMovePrevious

Case vbDataActionMoveNext

Case vbDataActionMoveLast

Case vbDataActionAddNew

Case vbDataActionUpdate

Case vbDataActionDelete

Case vbDataActionFind

Case vbDataActionBookmark

Case vbDataActionClose

End Select

Screen.MousePointer = vbHourglass

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

Data1.Refresh

End Sub

（2）frm1 窗体的代码如下：

Private Sub cmdAdd_Click()

Data1.Recordset.AddNew

End Sub

Private Sub cmdDelete_Click()

'如果删除记录集的最后一条记录

'记录或记录集中唯一的记录

Data1.Recordset.Delete

Data1.Recordset.MoveNext

End Sub

Private Sub cmdRefresh_Click()

'这仅对多用户应用程序才是需要的

Data1.Refresh

End Sub

Private Sub cmdUpdate_Click()

Data1.UpdateRecord

Data1.Recordset.Bookmark = Data1.Recordset.LastModified

End Sub

Private Sub cmdClose_Click()

Unload Me

End Sub

Private Sub Data1_Error(DataErr As Integer, Response As Integer)

'这就是放置错误处理代码的地方

'如果想忽略错误，注释掉下一行代码

'如果想捕捉错误，在这里添加错误处理代码

MsgBox "数据错误事件命中错误：" & Error$(DataErr)

Response = 0 '忽略错误

End Sub

Private Sub Data1_Reposition()

Screen.MousePointer = vbDefault

On Error Resume Next

'这将显示当前记录位置

'为动态集和快照

Data1.Caption = "记录：" & (Data1.Recordset.AbsolutePosition + 1)

'对于 Table 对象，当记录集创建后并使用下面的行时，

'必须设置 Index 属性

'Data1.Caption = "记录：" & (Data1.Recordset.RecordCount * (Data1.Recordset.PercentPosition * 0.01)) + 1

End Sub

Private Sub Data1_Validate(Action As Integer, Save As Integer)

'这是放置验证代码的地方

'当下面的动作发生时，调用这个事件

Select Case Action

Case vbDataActionMoveFirst

Case vbDataActionMovePrevious

Case vbDataActionMoveNext

Case vbDataActionMoveLast

Case vbDataActionAddNew

Case vbDataActionUpdate

Case vbDataActionDelete

Case vbDataActionFind

Case vbDataActionBookmark

Case vbDataActionClose

End Select

Screen.MousePointer = vbHourglass

End Sub

（3）Module1 模块的代码如下：

Public adoCon As New ADODB.Connection

Public adoRs As New ADODB.Recordset