Access开发培训
网站公告
·Access专家课堂QQ群号：151711184    ·Access快速开发平台下载地址及教程    ·欢迎加入Access专家课堂微信群！    ·如何快速搜索本站文章|示例|资料    
您的位置：　首页 > 技术文章 > Access数据库-模块/函数/VBA

共享软件作者制作的管理软件注册的动态链接库

来源:网络  点击数:8632  　 | 收藏 | 复制

时　间:2008-10-10 11:09:37
作　者:示知   ID：14  城市：长沙
摘　要:共享软件作者制作的管理软件注册的动态链接库
正　文:

       作为共享软件作者，注册码被非法公布是件令你十分头疼的事情。小弟制作了这么一个类库。希望能有所帮助。它每次在RegestCheck被执行一遍的时候生成动态的用户名及密码，并保存入注册表。但软件已经注册的话则不改变原来的注册信息。所以，盗用注册码对它是没用的。
 
它有三个方法，四个属性。RegestCheck用来检查您的共享软件是否注册，Regest用来注册您的共享软件。GetNamePassword是为Name，Password属性赋一个合法的值。Regested 属性是保存共享软件是否注册过的信息的。RegestedKey是您的软件在注册表LOCAL_MACHINE主键中注册的键名。至于RegestName，RegestPassword就是保存合法的用户名及密码的了。
 
例子程序如下：
Option Explicit
 
Private Sub Form_Load()
 
 Dim Temp As ClassRegest   ‘请先在”引用”中引用这个类（动态链接库）
 
 Set Temp = New ClassRegest
 
 Temp.RegestKey = "Software\RegestTest"   ‘设置你的软件在注册表中注册的键名
 Temp.Regestcheck   ‘判断是否注册, 判断结果保存在Regested属性中
 ‘必须先赋值RegestKey及执行一遍RegestCheck,其它的属性及方法才能被正确执行
 
 MsgBox "Regeted is " & Temp.Regested
 
 Temp.GetNamePassword ’通过一定的算法为RegestName,RegestPassword赋于一个合法的值
 MsgBox "name is: " & Temp.RegestName
 MsgBox "password is: " & Temp.RegestPassword
 
 Temp.Regest ‘如果共享软件没有注册,则注册这个软件
 
 Set Temp=Nothing
 
End Sub
 
现在把这个DLL动态链接库的源代码提供如下：
(VB6.0测试通过)
 
Option Explicit
 
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002 '注册表函数的几个参数
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_SET_VALUE As Long = &H2
Private Const REG_SZ As Long = 1
 
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, ByVal lpData As String, lpcbData 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, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
 
Private m_Regested As Boolean '是否注册属性
Private m_RegestKey As String '注册表中的子键名
Private m_Name As String      '用户名属性
Private m_Password As String '密码属性
 
Private nCount As Integer     '用来临时计数
Private lReturn As Long       '接收返回值
Private Const sTarget As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ,.;:" '用来生成随机文本
Private FSO As FileSystemObject '用来产生随机文件的文件系统对象
Private FSOFile As File
Private FSOString As TextStream
 
Private Sub Class_Initialize()
 
 m_Regested = False
 m_RegestKey = ""
 
End Sub
 
Public Sub RegestCheck()
 
 Dim sName As String * 9      '保存注册表中读出的用户名
 Dim sPassword As String * 26 '保存注册表中读出的密码
 Dim hEditKey As Long         '保存打开的注册表键的句柄
 Dim lRegOpenError As Long    '保存打开注册表某主键的返回值
 
 lRegOpenError = RegOpenKeyEx(HKEY_LOCAL_MACHINE, m_RegestKey, 0, KEY_QUERY_VALUE, hEditKey)
 
 If lRegOpenError <> 0 Then   '如果打开出错
 MsgBox "Open Reg Error!Terminate!Please examine RegestKey."
 Exit Sub
 End If
 
 lReturn = RegQueryValueEx(hEditKey, "Name", 0, REG_SZ, sName, 9)
 If lReturn = 2 Then          '如果Name键值不存在
 GoTo FORNEXT
 End If
 lReturn = RegQueryValueEx(hEditKey, "Password", 0, REG_SZ, sPassword, 26)
 If lReturn = 2 Then
 GoTo FORNEXT
 End If
 
 If KeyCheck(Left(sName, 8), Left(sPassword, 25)) = True Then
 m_Regested = True   'KeyCheck检查Name和Password是否为合法,合法则m_regested被设为True
 Exit Sub
 End If
 
FORNEXT:
 m_Regested = False   '未通过KeyCheck则m_Regested设为否
 
 Randomize            '初始化随机数生成器
 
 Dim hFileNumber As Integer          '打开当前目录下的Key.dat文件,该文件用来保存用以生成Name及Password的一个随机字符串
 hFileNumber = FreeFile
 If Right(App.Path, 1) = "\" Then
 Open App.Path & "Key.dat" For Binary As hFileNumber
 Else
 Open App.Path & "\Key.dat" For Binary As hFileNumber
 End If
 
 Dim iRandom As Integer                   '生成随机字符数组baRandom()
 Dim baRandom(1 To 100) As Byte
 Dim iTemp As Integer
 Dim iNameLength As Integer
 Dim iPasswordLength As Integer
 Dim iKeyLength As Integer
 iNameLength = 0
 iPasswordLength = 0
 For nCount = 1 To 100 Step 3
 If iNameLength = 8 Then
   baRandom(nCount) = &HFF
   nCount = nCount + 1
   iNameLength = 9
 End If
 baRandom(nCount) = CByte(CStr(Int(32 * Rnd)))
 iTemp = (CInt(baRandom(nCount)) + 1) ^ 2 - CInt(baRandom(nCount)) ^ 2
 baRandom(nCount + 1) = CByte(CInt(iTemp * Rnd))
 If iNameLength < 8 Then
   baRandom(nCount + 2) = CByte(Int((8 - iNameLength) * Rnd) + 1)
   iNameLength = iNameLength + CInt(baRandom(nCount + 2))
  Else
   If iPasswordLength < 25 Then
    baRandom(nCount + 2) = CByte(Int((25 - iPasswordLength) * Rnd + 1))
    iPasswordLength = iPasswordLength + CInt(baRandom(nCount + 2))
   Else
    iKeyLength = nCount - 1
    nCount = 100
   End If
 End If
 Next
  
 For nCount = 1 To iKeyLength            '在Key.dat中写入baRandom()
 Put #hFileNumber, nCount, baRandom(nCount)
 Next
 
 Close #hFileNumber
 
 Set FSO = CreateObject("Scripting.FileSystemObject") '生成一个1024字节的随机字符组成的ASIIC文件
 If Right(App.Path, 1) = "\" Then
  If FSO.FileExists(App.Path & "Value.dat") Then
   Set FSOFile = FSO.GetFile(App.Path & "Value.dat")
   Set FSOString = FSOFile.OpenAsTextStream(ForWriting, TristateFalse)
 Else
   Set FSOString = FSO.CreateTextFile(App.Path & "Value.dat", True, False)
 End If
 Else
 If FSO.FileExists(App.Path & "\Value.dat") Then
   Set FSOFile = FSO.GetFile(App.Path & "\Value.dat")
   Set FSOString = FSOFile.OpenAsTextStream(ForWriting, TristateFalse)
 Else
   Set FSOString = FSO.CreateTextFile(App.Path & "\Value.dat", True, False)
 End If
 End If
 For nCount = 1 To 1024
 FSOString.Write (Mid(sTarget, Int(56 * Rnd + 1), 1))
 Next
 
 lReturn = RegCloseKey(hEditKey)
 
 Erase baRandom
 
 Set FSO = Nothing
 Set FSOFile = Nothing
 Set FSOString = Nothing
 Close #hFileNumber
 
End Sub
 
 
Private Function KeyCheck(ForCheckName As String, ForCheckPassword As String) As Boolean
'接收两个从注册表中读出的字符串Name和Password
 
'如果注册表中没有Name和Password键值则此二值为空,以下检测该字符串第一个字符是否在sTarget中
 If InStr(1, sTarget, Left(ForCheckName, 1), vbTextCompare) = 0 or InStr(1, sTarget, Left(ForCheckPassword, 1), vbTextCompare) = 0 Then
 KeyCheck = False
 Exit Function
 End If
 
'调用CalculateNamePassword,返回合法的Name及Password
'返回值的形式为Name%Password
 
 Dim sTotal As String
 sTotal = CalculateNamePassword
 Dim sCalName As String
 Dim sCalPassword As String
 sCalName = Left(sTotal, 8)
 sCalPassword = Right(sTotal, 25)
 
'检测是否符合
 For nCount = 1 To 8
 If Mid(ForCheckName, nCount, 1) <> Mid(sCalName, nCount, 1) Then
   KeyCheck = False
   Exit Function
 End If
 Next
 
 For nCount = 1 To 25
 If Mid(ForCheckPassword, nCount, 1) <> Mid(sCalPassword, nCount, 1) Then
   KeyCheck = False
   Exit Function
 End If
 Next
 
 KeyCheck = True
 
End Function
 
Public Property Get Regested() As Variant                  '是否注册的只读属性
 Regested = m_Regested
End Property
 
Public Property Get RegestKey() As String                  '客户应用程序在注册表中的注册键
 RegestKey = m_RegestKey
End Property
 
Public Property Let RegestKey(ByVal vNewValue As String)
 m_RegestKey = vNewValue
End Property
 
Private Function CalculateNamePassword() As String         '用来以Name%Password格式返回
                                                           '合法用户名及密码的私有方法
'如果Value.dat不存在,则立即退出
 Set FSO = CreateObject("Scripting.FileSystemObject")
 If Right(App.Path, 1) = "\" Then
 If FSO.FileExists(App.Path & "Value.dat") = False Then
   CalculateNamePassword = ""
   Set FSO = Nothing
   Exit Function
 End If
 Else
 If FSO.FileExists(App.Path & "\Value.dat") = False Then
   CalculateNamePassword = ""
   Set FSO = Nothing
   Exit Function
 End If
 End If
 
 Dim sCalculateName As String        '合法的用户名
 Dim sCalculatePassword As String    '合法的密码
 sCalculateName = ""
 sCalculatePassword = ""
 
 Dim hFileNumberKey As Integer       '打开两个文件Key.dat和Value.dat
 hFileNumberKey = FreeFile
 If Right(App.Path, 1) = "\" Then
 Open App.Path & "Key.dat" For Binary As hFileNumberKey
 Else
 Open App.Path & "\Key.dat" For Binary As hFileNumberKey
 End If
 Dim hFileNumberValue As Integer
 hFileNumberValue = FreeFile
 If Right(App.Path, 1) = "\" Then
 Open App.Path & "Value.dat" For Binary As hFileNumberValue
 Else
 Open App.Path & "\Value.dat" For Binary As hFileNumberValue
 End If
 
 Dim bFirst As Byte
 Dim bSecond As Byte
 Dim bLength As Byte
 Dim bFF As Byte
 Dim bCode As Byte
 Dim iPasswordStart As Integer
 Dim iLength As Integer
 For nCount = 1 To 24 Step 3
 Get #hFileNumberKey, nCount, bFF
 If bFF <> &HFF Then
   Get #hFileNumberKey, nCount, bFirst
   Get #hFileNumberKey, nCount + 1, bSecond
   Get #hFileNumberKey, nCount + 2, bLength
   For iLength = 1 To CInt(bLength)
    Get #hFileNumberValue, CInt(bFirst) ^ 2 + CInt(bSecond) + iLength - 1, bCode
    sCalculateName = sCalculateName & Chr(bCode)
   Next
 Else
   iPasswordStart = nCount
   Exit For
 End If
 Next
 For nCount = iPasswordStart + 1 To 100 Step 3
 Get #hFileNumberKey, nCount, bFirst
 Get #hFileNumberKey, nCount + 1, bSecond
 Get #hFileNumberKey, nCount + 2, bLength
 For iLength = 1 To CInt(bLength)
   Get #hFileNumberValue, CInt(bFirst) ^ 2 + CInt(bSecond) + iLength - 1, bCode
   sCalculatePassword = sCalculatePassword & Chr(bCode)
   If Len(sCalculatePassword) = 25 Then
    nCount = 100
    Exit For
   End If
 Next
 Next
 
 CalculateNamePassword = sCalculateName & "%" & sCalculatePassword
 
 Set FSO = Nothing
 Close #hFileNumberKey
 Close #hFileNumberValue
 
End Function
 
Public Property Get RegestName() As String         '只读用户名属性
 RegestName = m_Name
End Property
 
Public Property Get RegestPassword() As String     '只读密码属性
 RegestPassword = m_Password
End Property
 
Public Sub GetNamePassword()                       '获得用户名及密码的公用方法
                                                   '调用一次就会给用户名属性和密码属性赋一合法值
 Dim sTotal As String
 
 sTotal = CalculateNamePassword
 m_Name = Left(sTotal, 8)
 m_Password = Right(sTotal, 25)
 
End Sub
 
Public Sub Regest()                                '以合法用户名及密码注册软件的公有方法
 
 Dim sTotal As String
 Dim sSubName As String
 Dim sSubPassword As String
 Dim hEditKey As Long
 
 sTotal = CalculateNamePassword
 sSubName = Left(sTotal, 8)
 sSubPassword = Right(sTotal, 25)
 
 Dim lRegOpenError As Long
 
 lRegOpenError = RegOpenKeyEx(HKEY_LOCAL_MACHINE, m_RegestKey, 0, KEY_SET_VALUE, hEditKey)
 
 If lRegOpenError <> 0 Then
 MsgBox "Open Reg Error!Terminate!Please examine RegestKey."
 Exit Sub
 End If
 
 Dim lReturn As Long
 lReturn = RegSetValueEx(hEditKey, "Name", 0, REG_SZ, sSubName, 8)
 lReturn = RegSetValueEx(hEditKey, "Password", 0, REG_SZ, sSubPassword, 25)
 
End Sub
 


Access软件网QQ交流群 (群号:54525238) 　　　　　　Access源码网店
【打印此文】【关闭窗口】

常见问答:

技术分类:

相关资源:

源码示例

学习心得

最新文章

专栏作家

关于我们 | 服务条款 | 在线投稿 | 友情链接 | 网站统计 | 网站帮助