RegCodes

Option Explicit
' Name: GenerateKeyCode
'
' Description:
'  This little routine generates a keycode for shareware registration in the
'  format XXXX-YYYYYYYYYY, based on the Name given as an argument. The first
'  four digits are a randomly generated seed value, which makes 8999 possible keycodes
'  for people with the same name (like John Smith). The last four digits are
'  the actual code.
'
' Written by:
'  Andy Carrasco (Copyright 1998)
'
Public Function GenerateKeyCode(sName As String) As String
  Dim sRandomSeed As String
  Dim sKeyCode As String
  Dim X As Long
  Dim KeyCounter As Long
  Dim PrimaryLetter As Long
  Dim CodedLetter As Long
  Dim sBuffer As String
    
  Randomize
  sRandomSeed = CStr(Int((9999 - 1000 + 1) * Rnd + 1000))
  sName = UCase$(sName)
  KeyCounter = 1
  
  'Clean up sName so there are no illegal characters.
  For X = 1 To Len(sName)
    If Asc(Mid$(sName, X, 1)) >= 65 And Asc(Mid$(sName, X, 1)) <= 90 Then sBuffer = sBuffer & Mid$(sName, X, 1)
  Next X
  
  sName = sBuffer
    
  'if the name is less than 10 characters long, pad it out with ASCII 65
  Do While Len(sName) < 10
    sName = sName + Chr$(65)
  Loop
    
  For X = 1 To Len(sName)
    PrimaryLetter = Asc(Mid$(sName, X, 1))
    CodedLetter = PrimaryLetter + CInt(Mid$(sRandomSeed, KeyCounter, 1))
    If CodedLetter < 90 Then
      sKeyCode = sKeyCode + Chr$(CodedLetter)
    Else
      sKeyCode = sKeyCode + "0"
    End If
    'Increment the keycounter
    KeyCounter = KeyCounter + 1
    If KeyCounter > 4 Then KeyCounter = 1
  Next X
  
  GenerateKeyCode = sRandomSeed + "-" + Left$(sKeyCode, 10)
  
End Function
' Name: VerifyKeyCode
'
' Description:
'  Verifies if a given keycode is valid for a given name.
'
' Parameters:
'  sName  - A string containing the user name to validate the key against
'  sKeyCode- A string containins the keycode in the form XXXX-YYYYYYYYYY.
'
Public Function VerifyKeyCode(sName As String, sKeyCode As String) As Boolean
  
  Dim sRandomSeed As String
  Dim X As Long
  Dim KeyCounter As Long
  Dim PrimaryLetter As Long
  Dim DecodedKey As String
  Dim AntiCodedLetter As Long
  Dim sBuffer As String
    
  sRandomSeed = Left$(sKeyCode, InStr(sKeyCode, "-") - 1)
  sName = UCase$(sName)
  sKeyCode = Right$(sKeyCode, 10)
  KeyCounter = 1
  
  'Clean up sName so there are no illegal characters.
  For X = 1 To Len(sName)
    If Asc(Mid$(sName, X, 1)) >= 65 And Asc(Mid$(sName, X, 1)) <= 90 Then sBuffer = sBuffer & Mid$(sName, X, 1)
  Next X
  
  sName = sBuffer
    
  'if the name is less than 10 characters long, pad it out with ASCII 65
  Do While Len(sName) < 10
    sName = sName + Chr$(65)
  Loop
    
  'now, decode the keycode
  
  For X = 1 To Len(sKeyCode)
    PrimaryLetter = Asc(Mid$(sKeyCode, X, 1))
    AntiCodedLetter = PrimaryLetter - CInt(Mid$(sRandomSeed, KeyCounter, 1))
    
    If PrimaryLetter = 48 Then 'zero
      DecodedKey = DecodedKey + Mid$(sName, X, 1) 'Take the corresponding letter from the name
    Else
      DecodedKey = DecodedKey + Chr$(AntiCodedLetter)
    End If
    'Increment the keycounter
    KeyCounter = KeyCounter + 1
    If KeyCounter > 4 Then KeyCounter = 1
  Next X
  
  If DecodedKey = Left$(sName, 10) Then
    VerifyKeyCode = True
  Else
    VerifyKeyCode = False
  End If
End Function