module2.bas

VB写的工业软件注册功能代码.采用复杂的加密软件件算法结合硬盘数据算法

Attribute VB_Name = "Module2"
Public Const MAX_FILENAME_LEN = 256
Public 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
Public Function DriveSerial(ByVal sDrv As String) As Long
'Usage:
'Dim ds As Long
'ds = DriveSerial("C")
Dim RetVal As Long
Dim str As String * MAX_FILENAME_LEN
Dim str2 As String * MAX_FILENAME_LEN
Dim a As Long
Dim b As Long
GetVolumeInformation sDrv & ":\", str, MAX_FILENAME_LEN, RetVal, a, b, str2, MAX_FILENAME_LEN
DriveSerial = RetVal
End Function

Public Function CheckId(ByVal SRC As Long, ByVal Value As String) As Boolean
Dim SourceString As String
Dim NewSRC As Long
For I = 0 To 10
    If (SRC And 2 ^ I) = 2 ^ I Then
        SourceString = SourceString + "1"
    Else
        SourceString = SourceString + "0"
    End If
Next I
If SRC < 0 Then
    SourceString = SourceString + "1"
Else
    SourceString = SourceString + "0"
End If

Dim Table As String
Dim TableIndex As Integer
'================================================================================
'这是密码表，根据你的要求换成别的，不过长度要一致
'================================================================================
'注意：这里的密码表变动后，对应的注册号生成器的密码表也要完全一致才能生成正确的注册号
Table = "JSDJFKLUWRUOISDH;KSADJKLWQ;ABCDEFHIHL;KLADSHKJAGFWIHERQOWRLQH"
'================================================================================
Dim Result As String
Dim MidWord As String
Dim MidWordValue As Byte
Dim ResultValue As Byte
For t = 1 To 1
    For I = 1 To Len(SourceString)
        MidWord = Mid(SourceString, I, 1)
        MidWordValue = Asc(MidWord)
        TableIndex = TableIndex + 1
        If TableIndex > Len(Table) Then TableIndex = 1
            ResultValue = Asc(Mid(Table, TableIndex, 1)) Mod MidWordValue
            Result = Result + Hex(ResultValue)
    Next I
    SourceString = Result
Next t
Dim BitTORool As Integer
For t = 1 To Len(CStr(SRC))
    BitTORool = SRC And 2 ^ t
        For I = 1 To BitTORool
            SourceString = Right(SourceString, 1) + Left(SourceString, Len(SourceString) - 1)
        Next I
Next t
If SourceString = Value Then CheckId = True
End Function
Public Function GetRegID(ByVal SRC As Long) As String
Dim SourceString As String
Dim NewSRC As Long
For I = 0 To 10
    If (SRC And 2 ^ I) = 2 ^ I Then
        SourceString = SourceString + "1"
    Else
        SourceString = SourceString + "0"
    End If
Next I
If SRC < 0 Then
    SourceString = SourceString + "1"
Else
    SourceString = SourceString + "0"
End If

Dim Table As String
Dim TableIndex As Integer
'================================================================================
'这是密码表，根据你的要求换成别的，不过长度要一致
'================================================================================
'注意：这里的密码表变动后，对应的注册号生成器的密码表也要完全一致才能生成正确的注册号
Table = "JSDJFKLUWRUOISDH;KSADJKLWQ;ABCDEFHIHL;KLADSHKJAGFWIHERQOWRLQH"
'================================================================================
Dim Result As String
Dim MidWord As String
Dim MidWordValue As Byte
Dim ResultValue As Byte
For t = 1 To 1
    For I = 1 To Len(SourceString)
        MidWord = Mid(SourceString, I, 1)
        MidWordValue = Asc(MidWord)
        TableIndex = TableIndex + 1
        If TableIndex > Len(Table) Then TableIndex = 1
            ResultValue = Asc(Mid(Table, TableIndex, 1)) Mod MidWordValue
            Result = Result + Hex(ResultValue)
    Next I
    SourceString = Result
Next t
Dim BitTORool As Integer
For t = 1 To Len(CStr(SRC))
    BitTORool = SRC And 2 ^ t
        For I = 1 To BitTORool
            SourceString = Right(SourceString, 1) + Left(SourceString, Len(SourceString) - 1)
        Next I
Next t
GetRegID = SourceString
End Function