Dim lianhuan() As Integer
Dim jcount() As Integer
Dim ze() As Integer
Dim tt()
Public ccount As Integer
Private Sub Command1_Click()
ccount = 0
Call asw
End Sub
Sub asw()
Dim i As Integer
Dim x As String
Dim y As String
Dim name As String
Dim z As String
Dim s As String
Dim z2 As Double
ReDim ze(10000)
ReDim tt(32)
ReDim lianhuan(10)
ReDim jcount(10000)
Dim wq As String
Dim aw As String
name = form1.Text1.Text
If name <> "" Then
x = DTOB(&H13572468, 32)
nl = Len(name)
If nl > 15 Then nl = 15
For i = 1 To nl
y = Mid(name, i, 1)
z = hadd(DTOB(Asc(y), 32), x)
z = hmul(z, DTOB(&H3721273, 32))
z = hadd(z, DTOB(&H24681357, 32))
s = z
z = hsar(z, 7)
s = hshl(s, &H19)
x = hor(z, s)
Next
z2 = BTOD(x)
For i = 1 To 8 '生成九连环的初始态
lianhuan(i) = Val(Mid(x, 32 - i, 1))
Next
lianhuan(9) = 1
Else
'提示不能为空
End If
For i = 9 To 1 Step -1 '解九连环
Call down(i)
Next
tt(0) = Val(Right(Str(z2), 1)) '生成长度31的参照数组
For i = 1 To 30
tt(i) = Int(z2 / 2) Mod 10
z2 = Int(z2 / 2)
Next
For i = 1 To ccount '生成注册码数组
If jcount(i - 1) >= tt((i - 1) Mod 31) Then
ze(i - 1) = jcount(i - 1) - tt((i - 1) Mod 31)
Else
ze(i - 1) = jcount(i - 1) + 10 - tt((i - 1) Mod 31)
End If
Next
For i = 0 To ccount - 1 '连接注册码数组成为字符串
aw = Trim(aw + Trim(Str(ze(i))))
Next
form1.Text2.Text = aw '显示注册码
End Sub
Sub down(i As Integer)
If lianhuan(i) <> 0 And i >= 1 Then
If i = 1 Then
lianhuan(1) = 0
jcount(ccount) = 1
ccount = ccount + 1
GoTo rrr
End If
up (i - 1)
For n = i - 2 To 1 Step -1
down (n)
Next
lianhuan(i) = 0
jcount(ccount) = i
ccount = ccount + 1
End If
rrr:
End Sub
Sub up(i As Integer)
If lianhuan(i) = 0 And i >= 1 Then
If i = 1 Then
lianhuan(1) = 1
jcount(ccount) = 1
ccount = ccount + 1
GoTo rrr2
End If
up (i - 1)
For n = i - 2 To 1 Step -1
down (n)
Next
lianhuan(i) = 1
jcount(ccount) = i
ccount = ccount + 1
End If
rrr2:
End Sub
Function hor(opr1 As String, opr2 As String) As String
For il = 1 To 32
s3 = Val(Mid(opr1, il, 1))
s4 = Val(Mid(opr2, il, 1))
If s3 Or s4 = 1 Then
sum = sum + "1"
Else
sum = sum + "0"
End If
Next
hor = sum
End Function
Function hshl(opr1 As String, opr2 As Integer) As String
l = Len(opr1)
For i = 1 To opr2
opr1 = Right(opr1, l - 1) + "0"
Next
hshl = opr1
End Function
Function hsar(opr1 As String, opr2 As Integer) As String
For i = 1 To opr2
If Left(opr1, 1) = 1 Then
opr1 = "1" + Left(opr1, Len(opr1) - 1)
Else
opr1 = "0" + Left(opr1, Len(opr1) - 1)
End If
Next
hsar = opr1
End Function
Function hadd(opr1 As String, opr2 As String) As String
Dim sum As String
s1 = opr1
s2 = opr2
For i = 1 To 32
s3 = Val(Mid(s1, 32 - i + 1, 1))
s4 = Val(Mid(s2, 32 - i + 1, 1))
Select Case s3 + s4 + cf
Case 0
sum = "0" + sum
cf = 0
Case 1
sum = "1" + sum
cf = 0
Case 2
sum = "0" + sum
cf = 1
Case 3
sum = "1" + sum
cf = 1
End Select
Next
hadd = sum
End Function
Function hmul(opr1 As String, opr2 As String) As String
Dim ji As String
Dim sum As String
s1 = opr1
s2 = opr2
ji = String(32, "0")
For i = 1 To 32
If Mid(s2, 32 - i + 1, 1) = 1 Then
tmp = s1 + String(i - 1, "0")
tmp = Right(tmp, 32)
sum = ""
cf = 0
For j = 1 To 32
s3 = Val(Mid(ji, 32 - j + 1, 1))
s4 = Val(Mid(tmp, 32 - j + 1, 1))
Select Case s3 + s4 + cf
Case 0
sum = "0" + sum
cf = 0
Case 1
sum = "1" + sum
cf = 0
Case 2
sum = "0" + sum
cf = 1
Case 3
sum = "1" + sum
cf = 1
End Select
Next
ji = sum
End If
Next
hmul = ji
End Function
Public Function DTOB(DV As Long, MD As Integer) As String
Dim result As String
Dim ND As Integer
DV = Abs(DV)
Do
result = CStr(DV Mod 2) & result
DV = Int(DV / 2)
Loop While DV > 0
ND = MD - Len(result)
If ND > 0 Then
result = String(ND, "0") & result
End If
DTOB = result
End Function
Public Function BTOD(BV As String) As Double
Dim i As Integer
Dim tmp As String
Dim result As Double
Dim ds As Integer
ds = Len(BV)
For i = ds To 1 Step -1
tmp = Mid(BV, i, 1)
If tmp = "1" Then result = result + 2 ^ (ds - i)
Next
BTOD = result
End Function
