|
Option Explicit Private Declare Function GetVolumeInformation Lib kernel _ 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 volNumber MCM FSF Fsys ) 将c盘序列号加密并显示在注册窗体的本机码中 localid = ＊＊＊＊＊volNumber＊＊＊＊＊ 加密算法 TextText = 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对象为用户定义一个会话通过与之关联的用户名和口令建立一个安全级别当不需要安全级别时可使用缺省的工作区DBEngineWorkspace() Set ws = DBEngineWorkspaces() 创建一个空的数据库文件dbLangGeneral参数用来确定数据驱动程序支持的参数 Set db = wsCreateDatabase(sPath & \***mdb dbLangGeneral) 创建一张新表 Set tdf = dbCreateTableDef(***) 创建first_time字段 Set fld = tdfCreateField(first_time dbDate ) tdfFieldsAppend fld 把first_time字段添加到表中 创建last_time字段 Set fld = tdfCreateField(last_time dbDate ) tdfFieldsAppend fld 把last_time字段添加到表中 创建times字段 Set fld = tdfCreateField(times dbInteger ) tdfFieldsAppend fld 把times字段添加到表中 dbTableDefsAppend tdf 将***表添加到***mdb中 dbClose 关闭***mdb Set db = wsOpenDatabase(sPath & \***mdb) 以可读写方式打开***mdb Set rst = dbOpenRecordset(***) 打开一个记录集 With rst AddNew 向记录集增加一条新记录 写入一条记录 Fields(first_time) = Date Fields(last_time) = Date Fields(times) = Update 将记录写入数据库 End With rstClose dbClose 关闭***mdb wsClose **********更改系统时间来实现隐藏注册库的修改时间*************** ……………………………………… ………………………………………… ………………………………………………… dbEncryptdbEncrypt (sPath & \***mdb) 数据库加密 Name sPath & \***mdb As sPath & \***** ********************将时间改会原来时间************************ ………………………… ………………………… MsgBox 这是你首次启动本系统!你的试用期为天今天是第一天谢谢使用! vbOKOnly + vbInformation 欢迎! ***Show 启动主窗体 Else 系统有***mdb文件则不是第一次运行就不用建立数据库文件了 Dim ws As Workspace Dim db As Database Dim rst As Recordset Dim num As Integer dbEncryptdbExplain (sPath & \*****) Set ws = Workspaces() Set db = wsOpenDatabase(sPath & \*****) Set rst = dbOpenRecordset(***) 开始检测用户是否修改了系统日期 rstMoveFirst If rstFields(last_time) > Date Or rstFields(times) > Then MsgBox 对不起你在本软件的试用期不可以修改系统日期否则将取消您的系统试用权如果你想继续使用本软件请您恢复系统日期谢谢合作! vbOKOnly + vbInformation 提示 End End If If Date rstFields(first_time) >= Then 设定试用期为天 MsgBox vbCrLf & 你已经启动本系统 & rstFields(times) & 次但已超过了软件天的试用期 & vbCrLf & vbCrLf & 如果您愿意继续使用本系统请将本机码以打电话(***********) & vbCrLf & vbCrLf & 或发邮件()的形式与***联系来得到注册码! vbOKOnly + vbInformation 提示 Else 仍在试用期内 num = rstFields(times) rstEdit rstFields(last_time) = Date rstFields(times) = num + rstUpdate MsgBox 这是你第 & rstFields(times) & 次使用本系统你还有 & (Date rstFields(first_time)) & 天的试用期祝你今天工件愉快！ vbOKOnly + vbInformation 提示 ***Show 启动你的主窗体 End If rstClose dbClose wsClose ***************更改系统时间来实现隐藏注册库的修改时间*************** …………………………………… ***************************************************************************** dbEncryptdbEncrypt (sPath & \***mi) 加密数据库 Name sPath & \***** As sPath & \***** 因在前面改动时间会影响库中的时间故在这里做一下假改动来达到修改时间的目的 ********************将时间改会原来时间************************ ……………………………………… ************************************************************** End If Unload register 关闭注册窗口 Exit Sub error: dbEncryptSaveError Registercancel_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 volNumber MCM FSF Fsys ) 得到硬盘序列号 Dim Tid As Long Dim regid As String Tid = Val(TextText) regid = Trim(TextText) If regid = ******************* Then 判断输入的密码是否同解密算法得到的密码一致 ***********************更改系统时间来实现隐藏注册库的修改时间*************** ……………………………… ***************************************************************************** MsgBox 恭喜您已经注册成功欢迎使用水利工程投资控制与评审系统 vbOKOnly + vbInformation 提示 *****将注册信息写入密码注册库***** dbEncryptdbExplain (sPath & \*****) 数据库解密 Set ws = DBEngineWorkspaces() Set db = wsOpenDatabase(sPath & \*****) Set rst = dbOpenRecordset(***) rstMoveFirst rstEdit rstFields(***) = |
