# Const 语句应用方案

## 知识概述

### 常量概念

常量是一个在程序运行时不会被改变的数值或字符串。通过声明和使用常量的标识符，代替一个在程序执行时不会改变的值，在程序维护时只需要修改这个常量的值，即可改变程序中所有以这个常量命名的值，从而使程序的维护变得简单。

常量是由系统提供的，可直接使用，它包括整型常量、浮点型常量、字符串型常量、逻辑型常量和日期时间型常量。下面对每种常量分别进行举例。

整型常量：12、-5、123455、&O104、&HFF5A；

浮点型常量：0.235、-0.254、-123554.5486、0.254E45、1.54D-9；

字符串常量：“你好”、“456”、“abcd”、“ ”；

逻辑型常量：True、False；

日期时间常量：#07/08/2007#、“12:52:00 AM”、“June 7,2007”。

注意：在使用类型说明符声明常量时，常量名与类型说明符之间不要有空格。

当程序中有多次重复使用的常量时，可以考虑将其定义为符号常量，即可以使用一个字符或字符串来表示该常量。

常量的声明可以使用 Const 语句。其语法格式如下：

语法

[Public | Private] Const constname [As type] = expression

Const 语句中各参数说明如表 1 所示。

表 1 Const 语句中的各参数的说明

参 数 | 描 述
Public | 可选的。该关键字用于在模块级别中声明在所有模块中对所有过程都可以使用的常数。在过程中不能使用
Private | 可选的。该关键字用于在模块级声明只能在包含该声明的模块中使用的常数。不能在过程中使用
constname | 必需的。常数的名称；遵循标准的变量命名约定
type | 可选的。常数的数据类型；可以是 Byte、Boolean、Integer、Long、Currency、Single、Double、Decimal（目前尚不支持）、Date、String 或 Variant 类型。所声明的每个变量都要使用一个单独的 As 类型子句
expression | 必需的。文字、其他常数，或由除 Is 之外的任意的算术操作符和逻辑操作符所构成的任意组合

说明：在模块级的声明中 Public 和 Private 省略的情况下，系统默认是 Private。在模块中使用 Public 语句进声明后的符号常量，就是一个全局常量，该常量可以在程序中所有模块的过程中使用。同样，用 Private 语句声明过的常量就是局部常量。

例如：

Const PI As Single=3.14159265357 '声明符号常量 PI 代替 3.14159265357

Print 3 * PI '结果为：9.42477796071

注意：窗体模块和类模块中不能声明符号常量

示例

使用 Const 语句可以声明用于代替文字值的常数。Public 常数在标准模块的通用部分声明，而不是在类模块中声明。Private 常数可以在任何模块类型的通用部分声明。

声明常数为数字的私有常数。

Const MyVar = 459

声明公用常数。

Public Const MyString = "HELP"

声明私有的整数常数。

Private Const MyInt As Integer = 5

在一行中声明多个常数。

Const MyStr = "Hello", MyDouble As Double = 3.4567

声明注册表关键字安全选项。

Const READ_CONTROL = &H20000

Const KEY_QUERY_VALUE = &H1

Const KEY_SET_VALUE = &H2

声明公用显示常量。

Public Const ChrWidth = 105 '单位宽度

Public Const ChrHeight = 2 * ChrWidth '单位高度

Public Const BorderWidth = 210 '预留边界

Public Const LineMax = 16 '最大显示行数

注意：常数可以使程序更具可读性以及易于修改。在程序运行时，常数不会像变量那样无意中被改变。

### 符号常量

当程序中有多次重复使用的常量时，可以考虑将其定义为符号常量，即可以使用一个字符或字符串来表示该常量。

常量的声明可以使用 Const 语句。其语法格式如下：

[Public | Private] Const <常量名> [As <数据类型>] = <常量表达式>

l Public：可选的。用于声明可在工程的所有模块的任何过程中使用这个常量。

l Private：可选的。用于声明只能在包含该声明的模块中使用常量。

l 常量名：必选的。用于指定该常量名称，必须是合法的 Visual Basic 标识符。

l 数据类型：可选的。也可以通过数据类型符号规定常量的类型。

l 常量表达式：必选的。常量表达式中包括常量和操作符，但不包含变量，而且计算结果总是常值。

说明：在模块级的声明中 Public 和 Private 省略的情况下，系统默认是 Private。在模块中使用 Public 语句进声明后的符号常量，就是一个全局常量，该常量可以在程序中所有模块的过程中使用。同样，用 Private 语句声明过的常量就是局部常量。

例如：

Const PI As Single=3.14159265357 '声明符号常量 PI 代替 3.14159265357

Print 3 * PI '结果为：9.42477796071

注意：窗体模块和类模块中不能声明符号常量

## 应用一：输出常量值

运行结果如图书馆所示：

图 1 Const 语句执行结果图

完整程序代码如下：

form1 窗体代码：

Option Explicit

Private Sub Form_Load()

Const READ_CONTROL = &H20000

Const KEY_QUERY_VALUE = &H1

Const KEY_SET_VALUE = &H2

Print READ_CONTROL

Print KEY_QUERY_VALUE

Print KEY_SET_VALUE

Print ChrWidth

Print ChrHeight

Print BorderWidth

Print LineMax

End Sub

模块代码：

Option Explicit

Public Const ChrWidth = 105 '单位宽度

Public Const ChrHeight = 2 * ChrWidth '单位高度

Public Const BorderWidth = 210 '预留边界

Public Const LineMax = 16 '最大显示行数

## 应用二：关于图书管理系统（frmAbout 窗体）完整程序代码

关于图书管理系统如图 1 所示。

图 1 关于图书管理系统

Option Explicit

' 注册表关键字安全选项...

Const READ_CONTROL = &H20000

Const KEY_QUERY_VALUE = &H1

Const KEY_SET_VALUE = &H2

Const KEY_CREATE_SUB_KEY = &H4

Const KEY_ENUMERATE_SUB_KEYS = &H8

Const KEY_NOTIFY = &H10

Const KEY_CREATE_LINK = &H20

Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _

KEY_CREATE_SUB_KEY + Y_ENUMERATE_SUB_KEYS + _

KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL

' 注册表关键字 ROOT 类型...

Const HKEY_LOCAL_MACHINE = &H80000002

Const ERROR_SUCCESS = 0

Const REG_SZ = 1 ' 独立的空的终结字符串

Const REG_DWORD = 4 ' 32 位数字

Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"

Const gREGVALSYSINFOLOC = "MSINFO"

Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"

Const gREGVALSYSINFO = "PATH"

Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Private Sub cmdSysInfo_Click()

Call StartSysInfo

End Sub

Private Sub cmdOK_Click()

Unload Me

End Sub

Public Sub StartSysInfo()

On Error GoTo SysInfoErr

Dim rc As Long

Dim SysInfoPath As String

' 试图从注册表中获得系统信息程序的路径及名称...

If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then

' 试图仅从注册表中获得系统信息程序的路径...

ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then

' 已知 32 位文件版本的有效位置

If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then

SysInfoPath = SysInfoPath & "\MSINFO32.EXE"

' 错误 - 文件不能被找到...

Else

GoTo SysInfoErr

End If

' 错误 - 注册表相应条目不能被找到...

Else

GoTo SysInfoErr

End If

Call Shell(SysInfoPath, vbNormalFocus)

Exit Sub

SysInfoErr:

MsgBox "此时系统信息不可用", vbOKOnly

End Sub

Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean

Dim i As Long ' 循环计数器

Dim rc As Long ' 返回代码

Dim hKey As Long ' 打开的注册表关键字句柄

Dim hDepth As Long

Dim KeyValType As Long ' 注册表关键字数据类型

Dim tmpVal As String ' 注册表关键字值的临时存储器

Dim KeyValSize As Long ' 注册表关键自变量的尺寸

'------------------------------------------------------------

' 打开 {HKEY_LOCAL_MACHINE...} 下的 RegKey

'------------------------------------------------------------

rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)

' 打开注册表关键字

If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' 处理错误...

tmpVal = String$(1024, 0) ' 分配变量空间

KeyValSize = 1024 ' 标记变量尺寸

'------------------------------------------------------------

' 检索注册表关键字的值...

'------------------------------------------------------------

rc = RegQueryValueEx(hKey, SubKeyRef, 0, _

KeyValType, tmpVal, KeyValSize) ' 获得/创建关键字值

If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' 处理错误

If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 外接程序空终结字符串...

tmpVal = Left(tmpVal, KeyValSize - 1) ' Null 被找到,从字符串中分离出来

Else ' WinNT 没有空终结字符串...

tmpVal = Left(tmpVal, KeyValSize) ' Null 没有被找到, 分离字符串

End If

'------------------------------------------------------------

' 决定转换的关键字的值类型...

'------------------------------------------------------------

Select Case KeyValType ' 搜索数据类型...

Case REG_SZ ' 字符串注册关键字数据类型

KeyVal = tmpVal ' 复制字符串的值

Case REG_DWORD ' 四字节的注册表关键字数据类型

For i = Len(tmpVal) To 1 Step -1 ' 将每位进行转换

KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' 生成值字符。

Next

KeyVal = Format$("&h" + KeyVal) ' 转换四字节的字符为字符串

End Select

GetKeyValue = True ' 返回成功

rc = RegCloseKey(hKey) ' 关闭注册表关键字

Exit Function ' 退出

GetKeyError ' 错误发生后将其清除...

KeyVal = "" ' 设置返回值到空字符串

GetKeyValue = False ' 返回失败

rc = RegCloseKey(hKey) ' 关闭注册表关键字

End Function

Private Sub Form_Load()

Me.Caption = Me.Caption & " " & frmmain.StatusBar1.Panels(2).Text

End Sub

## 应用三：屏蔽系统窗体中标题栏的按钮

在应用软件的窗体中都有“关闭”、“最大化”和“最小化”按钮，如果在设计软件的时候不想使用这些按钮，可以将这三个按钮屏蔽掉。如在酒店管理系统中，为了给结账操作带来方便，将标题栏的三个按钮都屏蔽掉，这样就会减少在结账的时候，由于误点击标题栏的“关闭”按钮关闭窗体等操作而造成的不必要的损失。屏蔽标题栏按钮界面如图 1 所示。

在窗口声明中加入以下代码：

Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Private Const MF_REMOVE = &H1000&

Private Const SC_COLSE = &HF060

Private Const SC_MAXIMIZE = &HF030

Private Const SC_MINIMIZE = &HF020

图 1 屏蔽标题栏的按钮

在窗体的 Load 事件中加入下面的代码，当窗体运行的时候标题栏的按钮都变为不可用。

Private Sub Form_Load()

b = 1

……

'关闭按钮不可用

RemoveMenu GetSystemMenu(frm_gkjzgl.hwnd, 0), SC_COLSE, MF_REMOVE

'最大化按钮不可用

RemoveMenu GetSystemMenu(frm_gkjzgl.hwnd, 0), SC_MAXIMIZE, MF_REMOVE

'最小化按钮不可用

RemoveMenu GetSystemMenu(frm_gkjzgl.hwnd, 0), SC_MINIMIZE, MF_REMOVE

End Sub

## 应用四：控制其他应用软件的运行

在应用工程当中控制其他应用软件的运行是常有的事，如在程序中调用 Word 文档信息、控制杀毒软件的运行以及运行写字版程序等等。在图 1 所示的运行程序界面中，程序运行之后，单击其按钮将会打开记事本程序；当关闭记事本程序时，系统将会弹出“程序运行完成”的消息框。

图 1 打开记事本程序

程序完整代码如下：

Option Explicit

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Private Const INFINITE = -1&

Private Const SYNCHRONIZE = &H100000

Private Sub command1_click()

Dim iTask, ret, pHandle As Long

iTask = Shell("notepad.exe", vbNormalFocus)

pHandle = OpenProcess(SYNCHRONIZE, False, iTask)

ret = WaitForSingleObject(pHandle, INFINITE)

ret = CloseHandle(pHandle)

MsgBox "程序运行完成！"

End Sub

Private Sub Form_Load()

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

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

End Sub

## 应用五：在预定的时间内锁定应用程序

在某些应用程序中，存放着一些重要的机密文件（如军事机密文件），不可以被泄露出去。为了避免文件外泻所造成的不必要损失，可以为应用软件作一个加锁程序，在程序界面中，只要在设定的时间范围内移动鼠标，就可以避免程序加锁；如果在设定的时间内程序一直处于未被操作的的状态，这样当程序运行时间大于设定锁定程序的时间时，锁定界面就会出现，对应用程序进行锁定，在这种情况下，只有输入正确的密码之后，才能解除锁定继续操作应用程序，如采购管理系统中的主界面窗体及锁定程序的窗体相组合就能够完成锁定程序的功能，如图 1、图 2 所示。

图 1 应用程序界面

图 2 程序锁定界面

在窗体及模块中加入以下代码：

'声明 API 函数

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

'定义一个结构

Private Type POINTAPI

X As Long

Y As Long

End Type

且在模块中声明 4 个全局变量：

Public Timer1_x, Timer1_y, Timer2_x, Timer2_y As String

在 frm_main 窗体中加入 3 个时钟控件 Timer_pd1、Timer_pd2、Timer_pd3，并且分别在这三个控件中加入下面的代码：

Private Sub Timer_pd1_Timer()

Dim P1 As POINTAPI

GetCursorPos P1

Timer1_x = P1.X

Timer1_y = P1.Y

Timer_pd1.Enabled = False

End Sub

Private Sub Timer_pd2_Timer()

Text1.Text = Val(Text1.Text) + 1

End Sub

Private Sub Timer_pd3_Timer()

Dim P1 As POINTAPI

GetCursorPos P1

Timer2_x = P1.X

Timer2_y = P1.Y

If Timer2_x = Timer1_x And Timer2_y = Timer1_y Then

If Val(Text1.Text) >= 10 Then

frm_lock.Show

Text1.Text = 1

Timer_pd2.Enabled = False

End If

Exit Sub

Else

frm_main.Text1.Text = 1

frm_main.Timer_pd1.Enabled = True

End If

End Sub

在 frm_lock 窗体中加入一个时钟控件 Timer2，并在控件中加入下面的代码：

Private Sub Timer2_Timer()

Text1.SetFocus

If Text1.Text = "ljm2004" Then

ter = False

frm_main.Timer_pd2.Enabled = True

frm_main.Text1.Text = 1

Unload Me

End If

End Sub

程序完整代码如下：

frm_lock 窗体的代码如下：

Option Explicit

Dim ter As Boolean

Private Sub Form_LostFocus()

Me.SetFocus

End Sub

Private Sub Form_Unload(Cancel As Integer)

If ter = True Then

Cancel = 5

Else

End If

End Sub

Private Sub Timer2_Timer()

Text1.SetFocus

If Text1.Text = "ljm2004" Then

ter = False

frm_main.Timer_pd2.Enabled = True

frm_main.Text1.Text = 1

Unload Me

End If

End Sub

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

Dim i As Integer

Dim c

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type POINTAPI

X As Long

Y As Long

End Type

Private Sub END_Click()

c = MsgBox("确认要退出采购管理系统吗？", 33, "采购管理系统")

If c = vbOK Then

End

Else

End If

End Sub

Private Sub Form_Load()

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

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

StatusBar1.Panels(3).Text = "当前操作员： Administrator"

i = 0

End Sub

Private Sub RELOAD_Click()

Unload Me

End Sub

Private Sub Timer1_Timer()

StatusBar1.Panels.Item(2).Text = Format(Now, "yyyy 年 mm 月 dd 日 hh 点 mm 分 ss 秒")

End Sub

Private Sub Timer_pd1_Timer()

Dim P1 As POINTAPI

GetCursorPos P1

Timer1_x = P1.X

Timer1_y = P1.Y

Timer_pd1.Enabled = False

End Sub

Private Sub Timer_pd2_Timer()

Text1.Text = Val(Text1.Text) + 1

End Sub

Private Sub Timer_pd3_Timer()

Dim P1 As POINTAPI

GetCursorPos P1

Timer2_x = P1.X

Timer2_y = P1.Y

If Timer2_x = Timer1_x And Timer2_y = Timer1_y Then

If Val(Text1.Text) >= 10 Then

frm_lock.Show

Text1.Text = 1

Timer_pd2.Enabled = False

Else

End If

Exit Sub

Else

frm_main.Text1.Text = 1

frm_main.Timer_pd1.Enabled = True

End If

End Sub

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

'声明 API 函数

Public i As Integer

Const EWX_LOGOFF = 0

Const EWX_SHUTDOWN = 1

Const EWX_REBOOT = 2

Const EWX_FORCE = 4

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

Const FLAGS = 3

Const HWND_TOPMOST = -1

Const HWND_NOTOPMOST = -2

Public SetTop As Boolean

Private Declare Function SetWindowPos Lib "user32" (ByVal h%, ByVal hb%, ByVal X%, ByVal Y%, ByVal cx%, ByVal cy%, ByVal f%) As Integer

Public Timer1_x, Timer1_y, Timer2_x, Timer2_y As String

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type POINTAPI

X As Long

Y As Long

End Type

Sub AlwaysOnTop(FormName As Form, bOnTop As Boolean)

Dim Success As Integer

If bOnTop = False Then

Success% = SetWindowPos(FormName.hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)

Else

Success% = SetWindowPos(FormName.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS)

End If

End Sub

## 应用六：将应用软件的使用次数写入注册表

对于软件开发人员来说，为了使用户能购买自己的正版软件，常常需要为所开发的软件编写试用程序。软件试用程序的编写有很多的方法，其中的一种是根据查询注册表中的程序运行次数来限制程序的使用次数，当软件的运行超过程序编写者所限定的次数时，就提示“软件试用到期”的信息。这样，用户如果还想继续使用该软件，就不得不购买软件的正版。

向注册表中写入信息或者修改注册表中的信息是通过声明一系列 Windows API 函数来实现的。具体用到的 API 函数及其说明请看下面在窗口中声明的代码：

Const REG_SZ = 1

Const REG_DWORD = 4

Const HKEY_CURRENT_USER = &H80000001

Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias _

"GetVolumeInformationA" (ByVal lpRootPathName As String, _

ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, _

lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _

lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _

ByVal nFileSystemNameSize As Long) As Long

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias _

"RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _

phkResult As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _

"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _

ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _

ByVal cbData As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _

"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _

ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _

"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _

ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long

Dim fso, txtfile

Dim mySerial As Long

Dim mylong As Long

在图书管理系统当中设计有一个软件试用程序，在每一次运行程序的时候，单击“试用”按钮，注册表中的软件使用次数就会加 1。系统注册界面如图 1、图 2 所示。

图 1 图书管理系统的试用程序

图 2 单击“试用”按钮后改变注册表中的软件使用次数

编写试用程序的相关代码：

Private Sub Form_Load()

Dim user1 As String

Dim reg1 As String

Dim ret1, ret2, lendata1, lendata2 As Long

ret1 = RegOpenKeyEx(HKEY_CURRENT_USER, "Software\图书综合管理系统\user", 0, 0, hKey1)

ret2 = RegOpenKeyEx(HKEY_CURRENT_USER, "Software\图书综合管理系统\reg", 0, 0, hKey2)

ret1 = RegQueryValueEx(hKey1, "用户名", 0, REG_SZ, ByVal vbNullString, lendata1)

ret2 = RegQueryValueEx(hKey2, "注册号", 0, REG_SZ, ByVal vbNullString, lendata2)

user1 = String(lendata1, Chr(0))

reg1 = String(lendata2, Chr(0))

RegQueryValueEx hKey1, "用户名", 0, REG_SZ, ByVal user1, lendata1

RegQueryValueEx hKey2, "注册号", 0, REG_SZ, ByVal reg1, lendata2

If Len(user1) > 1 And Len(reg1) > 1 Then

Load main_mm

main_mm.Show

Unload Me

End If

End Sub

Private Sub Command1_Click()

Dim hKey As Long

Dim time1 As Long

Dim lendata As Long

Dim ret As Long

ret = RegOpenKeyEx(HKEY_CURRENT_USER, "Software\图书综合管理系统\time", 0, 0, hKey)

ret = RegQueryValueEx(hKey, "使用次数", 0, REG_DWORD, 0, lendata)

RegQueryValueEx hKey, "使用次数", 0, REG_DWORD, time1, lendata

RegCreateKey HKEY_CURRENT_USER, "Software\图书综合管理系统\time", hKey

If time1 < 100 Then '软件的试用次数为 100 次

RegSetValueEx hKey, "使用次数", 0, REG_DWORD, time1 + 1, 4

MsgBox "欢迎使用本软件的正版软件"

Else

MsgBox "软件试用到期，请注册！"

End

End If

End Sub

程序完整代码如下：

Const REG_SZ = 1

Const REG_DWORD = 4

Const HKEY_CURRENT_USER = &H80000001

Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias _

"GetVolumeInformationA" (ByVal lpRootPathName As String, _

ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, _

lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _

lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _

ByVal nFileSystemNameSize As Long) As Long

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias _

"RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _

phkResult As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _

"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _

ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _

ByVal cbData As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _

"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _

ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _

"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _

ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long

Dim fso, txtfile

Dim mySerial As Long

Dim mylong As Long

Private Sub Form_Load()

Dim user1 As String

Dim reg1 As String

Dim ret1, ret2, lendata1, lendata2 As Long

ret1 = RegOpenKeyEx(HKEY_CURRENT_USER, "Software\图书综合管理系统\user", 0, 0, hKey1)

ret2 = RegOpenKeyEx(HKEY_CURRENT_USER, "Software\图书综合管理系统\reg", 0, 0, hKey2)

ret1 = RegQueryValueEx(hKey1, "用户名", 0, REG_SZ, ByVal vbNullString, lendata1)

ret2 = RegQueryValueEx(hKey2, "注册号", 0, REG_SZ, ByVal vbNullString, lendata2)

user1 = String(lendata1, Chr(0))

reg1 = String(lendata2, Chr(0))

RegQueryValueEx hKey1, "用户名", 0, REG_SZ, ByVal user1, lendata1

RegQueryValueEx hKey2, "注册号", 0, REG_SZ, ByVal reg1, lendata2

If Len(user1) > 1 And Len(reg1) > 1 Then

Load main_mm

main_mm.Show

Unload Me

End If

End Sub

Private Sub Command1_Click()

Dim hKey As Long

Dim time1 As Long

Dim lendata As Long

Dim ret As Long

ret = RegOpenKeyEx(HKEY_CURRENT_USER, "Software\图书综合管理系统\time", 0, 0, hKey)

ret = RegQueryValueEx(hKey, "使用次数", 0, REG_DWORD, 0, lendata)

RegQueryValueEx hKey, "使用次数", 0, REG_DWORD, time1, lendata

RegCreateKey HKEY_CURRENT_USER, "Software\图书综合管理系统\time", hKey

If time1 < 100 Then

RegSetValueEx hKey, "使用次数", 0, REG_DWORD, time1 + 1, 4

MsgBox "欢迎使用本软件的正版软件"

Else

MsgBox "软件试用到期，请注册！"

End

End If

End Sub

Private Sub Command3_Click()

End

End Sub

## 应用七：为应用程序添加关机功能

有时候为了提高计算机的工作效率，可以在应用工程中添加关闭计算机的功能。如在酒店管理系统当中，处理完一天的工作任务之后，不必要关闭程序之后再关闭计算机，可以直接在系统中执行关闭计算机的操作，这样不仅大大提高了关机的速度，也方便了操作员的操作。如图 1 在酒店管理系统的主界面中单击“关闭计算机“菜单项后弹出的关闭计算机窗体中，可以进行关闭计算机或重启计算机的操作。

图 1 在应用程序当中关闭计算机

在应用程序中可以通过调用 ExitWindowsEx 函数退出 Windows 操作系统，其中用到了 3 个常量 SHUTDOWN、REBOOT、LOGOFF，它们的作用分别是关闭计算机、重启计算机和注销计算机，具体用法请参阅下面的程序代码。

在 frm_exit 窗口声明中加入如下的代码：

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

Const SHUTDOWN = 1 '关闭计算机

Const REBOOT = 2 '重启计算机

Const LOGOFF = 0 '注销计算机

单击“确定”按钮的事件代码如下：

Private Sub Command1_Click()

Dim R As Integer, wReserved As Integer

If Combo1.Text = "关闭计算机" Then

R = ExitWindowsEx(SHUTDOWN, wReserved)

ElseIf Combo1.Text = "重启计算机" Then

R = ExitWindowsEx(REBOOT, wReserved)

Else

End If

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

## 应用九：设置操作系统的任务栏模块

用户进入系统之后，选择“系统维护”/“设置任务栏”选项，打开“设置操作系统的任务栏”模块，如图 1 所示。

图 1 设置操作系统的任务栏模块

程序完整代码如下：

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const SWP_SHOWWINDOW As Long = &H40

Private Const SWP_HIDEWINDOW As Long = &H80

Private Const SWP_NOACTIVATE As Long = &H10

Private Sub Command1_Click() '隐藏任务栏

Dim hide As Long

hide = FindWindow("Shell_traywnd", vbNullString)

Call SetWindowPos(hide, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)

Command1.Enabled = False

Command2.Enabled = True

End Sub

Private Sub Command2_Click() '显示任务栏

Dim hide As Long

hide = FindWindow("Shell_traywnd", vbNullString)

Call SetWindowPos(hide, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)

Command2.Enabled = False

Command1.Enabled = True

End Sub

Private Sub Form_Load()

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

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

End Sub

## 应用十：服务器模块

在“局域网通讯（服务器端）”模块中单击“设置连接”按钮，打开“服务器”模块，如图 1 所示。

图 1 服务器模块

程序完整代码如下：

Public ips As String

Const sBaseBar = "BaseBar"

Const sTrayWindow = "Shell_TrayWnd"

Const sTrayNotify = "TrayNotifyWnd"

Const sStartButton = "Button"

Const sAppSwitchBar = "ReBarWindow32"

Const sAppSwitch = "MSTaskSwWClass"

Const sAppIcon = "ToolbarWindow32"

Const sTrayClock = "TrayClockWClass"

Const sDesktopIcon = "ShellDll_DefView"

Const sProgman = "Progman"

Const WM_USER = &H400

Const TPM_NONOTIFY = &H80

Const SW_SHOW = 5

Const SW_HIDE = 0

Const SW_NORMAL = 1

Const SW_RESTORE = 9

Const SW_SHOWDEFAULT = 10

Const SW_SHOWNA = 8

Const SW_SHOWNOACTIVATE = 4

Const SWP_ASYNCWINDOWPOS = &H4000

Const HWND_TOP = 0

Const TBM_GETPOS = WM_USER

Dim timer

Public wnd As Long

Private Sub Command1_Click()

If Text3.Text = "" Then

MsgBox "请输入本机端口", 48, "酒店管理系统"

ElseIf Text4.Text = "" Then

MsgBox "请输入客户端端口", 48, "酒店管理系统"

Else

scksever.LocalPort = Text3.Text

scksever.RemotePort = Text4.Text

scksever.Listen

MsgBox "设本机为服务器成功！", vbInformation, "提示"

Command1.Enabled = False

End If

End Sub

Private Sub Command3_Click()

frm_szlj.hide

End Sub

Private Sub Form_Load()

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

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

Timer1.Enabled = True

Text2.Text = scksever.LocalIP

End Sub

Private Sub scksever_Connect()

MsgBox "连接成功", vbInformation, "OK"

End Sub

Private Sub scksever_ConnectionRequest(ByVal requestID As Long)

If scksever.State <> 0 Then scksever.Close

scksever.Accept requestID

End Sub

Private Sub scksever_DataArrival(ByVal bytesTotal As Long)

Dim strdata As String

Dim sdata As String

scksever.GetData strdata

sdata = Left$(strdata, 7)

Select Case sdata

'系统消息

Case "SYSINFO"

xtxx = Right$(strdata, Len(strdata) - 7)

'发送消息

Case "SENDINF"

Dim aa, temp1

sendxx = Right$(strdata, Len(strdata) - 7)

aa = "来自客户机 " + sendxx + " " + timer

frm_jywth.Text2.Text = aa

frm_jywth.rtbSave.Text = frm_jywth.rtbSave.Text + Chr(13) + Chr(10) + aa

frm_jywth.StatBar1.Panels(3).Text = "请注意：您有一个新信息"

frm_jywth.Cmd_hfxx.Caption = "接收信息"

frm_jywth.Show

frm_jywth.Refresh

1

'关闭服务端

Case "OUITMYF"

scksever.Close

scksever.Listen

Timer1.Enabled = True

Case "GETFXIF"

xtxx = Right$(strdata, Len(strdata) - 7)

End Select

End Sub

Private Sub Timer1_Timer()

Dim strz As String

Select Case scksever.State

Case 6

strz = "正在连接"

Case 7

strz = "已连接"

Text1.Text = scksever.RemoteHostIP

Case 2

strz = "监听"

End Select

StatusBar1.Panels(2).Text = strz

frm_jywth.StatBar1.Panels(2) = strz

End Sub

Private Sub Timer2_Timer()

timer = Format(Now, "mm-dd hh:mm:ss")

End Sub