开发手记（六）——共享软件注册程序编写实例(2)
开发手记（六）——共享软件注册程序编写实例(2) 开发手记（六）——共享软件注册程序编写实例(2)
－为保证文章完整性，谢绝对某篇而非全部手记的转载（mi6236）
Option Explicit
Private Declare Function GetVolumeInformation Lib 'kernel32' _
Alias 'GetVolumeInformationA' (ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long '等到某一磁盘分区的信息
‘＊＊＊＊＊＊＊＊＊＊＊＊注册窗体＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
’运用另一个***.mdb来控制软件是否超出试用期
Private Sub Form_Load()
'根据C盘序列号得到原ID
Dim Driver, VolName, Fsys As String
Dim volNumber, MCM, FSF As Long
Driver = 'c:\'
Dim res As Long
Dim localid As Long
res = GetVolumeInformation(Driver, VolName, 127, volNumber, MCM, FSF, Fsys, 127)
'将c盘序列号加密并显示在注册窗体的本机码中
localid = ＊＊＊＊＊volNumber＊＊＊＊＊ ‘加密算法
Text1.Text = localid‘显示经加密后的本机码
End Sub
Private Sub cancel_Click()
On Error GoTo error
'检测系统文件夹是否有***.mdb文件，如果没有，则是系统第一次安装，建立此数据库文件
If Dir(sPath & '\***.**') = '' Then
Dim ws As Workspace
Dim db As Database
Dim tdf As TableDef
Dim fld As Field
Dim rst As Recordset
'DBEngine对象相当于Jet数据库引擎，不需要创建该对象,CreateWorkspace创建一个工作区对象
'Workspace对象为用户定义一个会话，通过与之关联的用户名和口令建立一个安全级别。当不需要安全级别时可使用缺省的工作区DBEngine.Workspace(0)
Set ws = DBEngine.Workspaces(0)
'创建一个空的数据库文件，dbLangGeneral参数用来确定数据驱动程序支持的参数
Set db = ws.CreateDatabase(sPath & '\***.mdb', dbLangGeneral)
'创建一张新表
Set tdf = db.CreateTableDef('***')
'创建first_time字段
Set fld = tdf.CreateField('first_time', dbDate, 8)
tdf.Fields.Append fld '把first_time字段添加到表中
'创建last_time字段
Set fld = tdf.CreateField('last_time', dbDate, 8)
tdf.Fields.Append fld '把last_time字段添加到表中
'创建times字段
Set fld = tdf.CreateField('times', dbInteger, 2)
tdf.Fields.Append fld '把times字段添加到表中
db.TableDefs.Append tdf '将***表添加到***.mdb中
db.Close '关闭***.mdb
Set db = ws.OpenDatabase(sPath & '\***.mdb') '以可读写方式打开***.mdb
Set rst = db.OpenRecordset('***') '打开一个记录集
With rst
.AddNew '向记录集增加一条新记录
'写入一条记录
.Fields('first_time') = Date
.Fields('last_time') = Date
.Fields('times') = 1
.Update '将记录写入数据库
End With
rst.Close
db.Close '关闭***.mdb
ws.Close
'**********更改系统时间，来实现隐藏注册库的修改时间***************
………………………………………
…………………………………………
…………………………………………………
dbEncrypt.dbEncrypt (sPath & '\***.mdb') '数据库加密
Name sPath & '\***.mdb' As sPath & '\***.**'
'********************将时间改会原来时间************************
…………………………
…………………………
MsgBox '这是你首次启动本系统!你的试用期为30天，今天是第一天，谢谢使用!', vbOKOnly + vbInformation, '欢迎!'
***.Show '启动主窗体
Else '系统有***.mdb文件，则不是第一次运行，就不用建立数据库文件了.
Dim ws2 As Workspace
Dim db2 As Database
Dim rst2 As Recordset
Dim num As Integer
dbEncrypt.dbExplain (sPath & '\***.**')
Set ws2 = Workspaces(0)
Set db2 = ws2.OpenDatabase(sPath & '\***.**')
Set rst2 = db2.OpenRecordset('***') '开始检测用户是否修改了系统日期
rst2.MoveFirst
If rst2.Fields('last_time') > Date Or rst2.Fields('times') > 100 Then
MsgBox '对不起，你在本软件的试用期不可以修改系统日期，否则将取消您的系统试用权，如果你想继续使用本软件。请您恢复系统日期，谢谢合作!', vbOKOnly + vbInformation, '提示'
End
End If
If Date - rst2.Fields('first_time') >= 30 Then '设定试用期为30天
MsgBox vbCrLf & '你已经启动本系统' & rst2.Fields('times') & '次，但已超过了软件30天的试用期。' & vbCrLf & vbCrLf & '如果您愿意继续使用本系统，请将“本机码”以打电话(***-********)' & vbCrLf & vbCrLf & '或发邮件(mi6236@tom.com)的形式与***联系来得到注册码!', vbOKOnly + vbInformation, '提示'
Else
'仍在试用期内
num = rst2.Fields('times')
rst2.Edit
rst2.Fields('last_time') = Date
rst2.Fields('times') = num + 1
rst2.Update
MsgBox '这是你第' & rst2.Fields('times') & '次使用本系统，你还有' & 30 - (Date - rst2.Fields('first_time')) & '天的试用期，祝你今天工件愉快！', vbOKOnly + vbInformation, '提示'
***.Show '启动你的主窗体
End If
rst2.Close
db2.Close
ws2.Close
'***************更改系统时间，来实现隐藏注册库的修改时间***************
……………………………………
'*****************************************************************************
dbEncrypt.dbEncrypt (sPath & '\***.mi') '加密数据库
Name sPath & '\***.**' As sPath & '\***.**' '因在前面改动时间会影响库中的时间，故在这里做一下假改动来达到修改时间的目的。
'********************将时间改会原来时间************************
………………………………………
'**************************************************************
End If
Unload register '关闭注册窗口
Exit Sub
error:
dbEncrypt.SaveError 'Register-cancel_Click'
End Sub
Private Sub enter_Click()
On Error GoTo SaveErr:
'进行注册，验证注册ID
Dim ws As Workspace
Dim db As Database
Dim tdf As TableDef
Dim rst As Recordset
Dim fld As Field
Dim Driver, VolName, Fsys As String
Dim volNumber, MCM, FSF As Long
Driver = 'c:\'
Dim res As Long
res = GetVolumeInformation(Driver, VolName, 127, volNumber, MCM, FSF, Fsys, 127) '得到硬盘序列号
Dim Tid As Long
Dim regid As String
Tid = Val(Text1.Text)
regid = Trim(Text2.Text)
If regid = ******************* Then '判断输入的密码是否同解密算法得到的密码一致
'***********************更改系统时间，来实现隐藏注册库的修改时间***************
………………………………
'*****************************************************************************
MsgBox '恭喜您已经注册成功，欢迎使用水利工程投资控制与评审系统', vbOKOnly + vbInformation, '提示'
'*****将注册信息写入密码注册库*****
dbEncrypt.dbExplain (sPath & '\***.**') '数据库解密
Set ws = DBEngine.Workspaces(0)
Set db = ws.OpenDatabase(sPath & '\***.**')
Set rst = db.OpenRecordset('***')
rst.MoveFirst
rst.Edit
rst.Fields('***') = 1
rst.Update
db.Close
dbEncrypt.dbEncrypt (sPath & '\***.**') '数据库加密
'********************将时间改会原来时间************************
………………………
'**************************************************************
Unload ***
***.Show '进入登录窗体
Else
MsgBox vbCr & '注册码不正确，请重新输入。' & vbCrLf & vbLf & '如果您想试用本软件可单击“取消”按钮', vbOKOnly + vbInformation, '提示'
Exit Sub
End If
Exit Sub
SaveErr:
dbEncrypt.SaveError 'Register-enter_Click'
End Sub
（未完待续）
