class1.cls

vb注册码生成器,可以自动生成人以数量的17位由阿拉伯数字和字母组成的注册码！

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*************************************************
' Copyright Carl Harvey
' This simple class can show how to generate registery code and validate them
' get your program registered by the user
' Code e.g  123R - 23354 - 234R - 216F
'
' Formula :
'          234R > 123R And 234R > 216F
'          23354 = 123R + 234R + 216F
'
' Note: letters must be converted to ASCII and - 80
' www.harveysolution.t2u.com
'*************************************************
Function GetRegCode() As String
Num1 = GetRandomNumber(5001, 9998)
Do
   Num3 = GetRandomNumber(5000, 9999)
   DoEvents
   If Num3 < Num1 Then Exit Do
Loop
'make sure to start at 5002 to have a good result number for the first condition
Do
   Num2 = GetRandomNumber(5002, 9999)
   DoEvents
   If Num2 > Num1 And Num2 > Num3 Then Exit Do
Loop
Num4 = Num1 + Num2 + Num3
GetRegCode = ChangeNumForLetter(Num1) & "-" & Num4 & "-" & ChangeNumForLetter(Num2) & "-" & ChangeNumForLetter(Num3)
End Function
Private Function GetRandomNumber(R1, R2) As Long
Randomize
GetRandomNumber = Int(((R2 - R1 + 1) * Rnd) + R1)
End Function
Private Function ChangeNumForLetter(CNum) As String
numt = GetRandomNumber(1, 4)
numt2 = Mid(CNum, numt, 1)
If numt > 1 And numt < 4 Then
 bef1 = Mid(CNum, 1, numt - 1)
 aft1 = Mid(CNum, numt + 1)
 ChangeNumForLetter = bef1 & Chr(numt2 + 80) & aft1
ElseIf numt = 1 Then
 ChangeNumForLetter = Chr(numt2 + 80) & Mid(CNum, 2)
ElseIf numt = 4 Then
 ChangeNumForLetter = Mid(CNum, 1, 3) & Chr(numt2 + 80)
End If
End Function
Function ValidateRegCode(A, B, C, D) As Boolean
Dim cdnum2 As Long
cdNum1 = ConvertLetToNum(A)
cdnum2 = B
cdNum3 = ConvertLetToNum(C)
cdNum4 = ConvertLetToNum(D)
If cdNum3 > cdNum1 And cdNum3 > cdNum4 Then
  rep = cdNum1 + cdNum3 + cdNum4
  ValidateRegCode = IIf(rep = cdnum2, True, False)
Else
  ValidateRegCode = False
End If
End Function
Private Function ConvertLetToNum(Code) As Long
Dim bef1, aft1: bef1 = ""
On Error GoTo BadLetter
For i = 1 To Len(Code)
  If Asc(Mid(Code, i, 1)) > 57 Then
      aft1 = IIf(i < Len(Code), Mid(Code, i + 1), "")
      ConvertLetToNum = bef1 & Asc(Mid(Code, i, 1)) - 80 & aft1
      Exit For
  Else
    bef1 = bef1 & Mid(Code, i, 1)
  End If
Next
Exit Function
BadLetter:
ConvertLetToNum = 0
End Function