开发手记(六)——共享软件注册程序编写实例(2)

- 中国WEB开发者网络 (http://www.webasp.net)
-- 技术教程 (http://www.webasp.net/article/)
--- 开发手记(六)——共享软件注册程序编写实例(2) (http://www.webasp.net/article/27/26542.htm)
-- 作者:未知
-- 发布日期: 2005-09-16

-为保证文章完整性,谢绝对某篇而非全部手记的转载(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

(未完待续)

webasp.net