小弟為共享軟體作者製作的管理軟體註冊的動態連結庫 (轉)

小弟為共享軟體作者製作的管理軟體註冊的動態連結庫 (轉)[@more@] 

小弟為共享作者製作的管理軟體註冊的動態連結庫

 :namespace prefix = o ns = "urn:schemas--com::office" />

作為共享軟體作者，註冊碼被公佈是件令你十分頭疼的事情。小弟製作了這麼一個類庫。希望能有所幫助。它每次在RegestCheck被一遍的時候生成動態的名及密碼，並儲存入登錄檔。但軟體已經註冊的話則不改變原來的註冊資訊。所以，註冊碼對它是沒用的。

 

它有三個方法，四個屬性。RegestCheck用來檢查您的共享軟體是否註冊，Regest用來註冊您的共享軟體。GetNamePass是為Name，Password屬性賦一個合法的值。Regested 屬性是儲存共享軟體是否註冊過的資訊的。RegestedKey是您的軟體在登錄檔LOCAL_MACHINE主鍵中註冊的鍵名。至於RegestName，RegestPassword就是儲存合法的使用者名稱及密碼的了。

 

例子如下：

Option Explicit

 

Private Sub Form_Load()

 

 Dim Temp As ClassRegest  ‘請先在”引用”中引用這個類（動態連結庫）

 

 Set Temp = New ClassRegest

 

 Temp.RegestKey = "SoftwareRegestTest"  ‘設定你的軟體在登錄檔中註冊的鍵名

 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動態連結庫的提供如下：

(.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 "adv32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal sesired 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 As FileSystem  '用來產生隨機的檔案

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!Tenate!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設為否

 

 Ranize  '初始化隨機數生成器

 

 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