endedemo.frm

产生程序序列号的范例

' requests of readers in the Forum.  (Since I myself have only a very limited knowledge
' of cryptography, I would not entertain possible questions extended beyond the scope of
' this code.  Reader should search for materials from authoritative sources instead.).
' ---------------------------------------------------------------------------------------
'
' Note:
'
' In this demo, instead of using a separate password to seed the SBox, the key code
' itself is being used here.  The result is: if you forget your password, no one can save
' you, not even the system administrator - like the login password in a Unix system.
'
' ---------------------------------------------------------------------------------------
'
' Basic Introduction:
'
' Cryptography is both science and art of scrambling and unscrambling data in code. When
' applied to computer security, it is to authenticate access rights and to maintain data
' integrity.  Cryptographic mechanisms use both an algorithm and a secret key. Other
' things equal, the more bits in a key, the less chance of the key being compromised.
'
' Main types of cryptographic functions exist: notably the symmetric encryption and the
' asymmetric (public) encryption; each has a variety of algorithms developed or being
' developed. Some of the more common ones used today are the Data Encryption Standard
' (DES), 3DES, RC2 and RC4, and the International Data Encryption Algorithm (IDEA).
'
' RC4 (R. Rivest's Cipher?) is a symmetric algorithm. It uses a substitution-box of
' a size of 256 entries, of which a particular permutations is a function of the key.
' Because the key byte is then XORed with plaintext to produce ciphertext (and vice
' versa), the same sub-routine is used for both ciphering and subsequent deciphering.
' ---------------------------------------------------------------------------------------

Dim arrSBox(0 To 255) As Integer
Dim arrPW(0 To 255) As Integer
Dim Bi As Integer, Bj As Integer
Const serialCodeLen1 = 8
Const serialCodeLen2 = 15
Const keyCodeLen = 8
Dim mresult



Private Sub Form_Load()
    txbSerialCode.Locked = True            ' Meant to be generated by system only
    txbKeyCode.Locked = True               ' To ensure integrity for pass checking
End Sub



Private Sub cmdExit_Click()
    Unload Me
End Sub



' Reiteration: There are endless ways of doing things!
Private Sub cmdGenSerialCode_Click()
     On Error Resume Next
     
     Dim alphas As String
     Dim startingPos As Integer
     Dim primemary As String
     Dim serials As String
     Dim char As String
     Dim i As Integer, j As Integer
     
     Dim mKey As Integer
     Dim x As Integer, y As Integer
     Dim mCode As Integer
     Dim alphaCode As Integer
     Dim SeriesUserName As String
     Dim SeriesKeyCode As String
     Dim strSerial As String
     
        ' Form a string of 26 letters' long; every alpha is possible to be included
     alphas = ""
     For i = 1 To 26
          Randomize
          alphas = alphas + Chr(CInt(25 * Rnd) + 65)
     Next i
     
        ' As we are to take a length of serialCodeLen1, we start from a certain
        ' position of the strAlphas and taking the said length
     Randomize
     startingPos = random * (25 - serialCodeLen1) + 1
     Primary = Mid(alphas, startingPos, serialCodeLen1)
     
        ' Generate a serial no. of 5-digit, say from 3 to 7 positions of alphas
     serials = ""
     For i = 3 To 7
          char = Mid(alphas, i, 1)
          j = CInt(Asc(char) Mod 10)
          serials = serials & CStr(j)
     Next i

        ' Key code = primary & serials, separated by "-"
     txbSerialCode.Text = Left(Primary, 4) & "-" & Right(Primary, 4) & "-" & serials
End Sub



' Note: Not much validation is attempted in this demo
Private Sub cmdGenKeyCode_Click()
     On Error Resume Next
     Dim tmp As String
     Dim i As Integer
     Dim strTmp As String
     Dim intTmp As Integer
     Dim lngTmp As Long
     Dim sumTmp As Integer
     Dim checkDigit As String
     Dim mSerial As Long
     
     If Len(txbSerialCode.Text) <> serialCodeLen2 Then
          MsgBox "No serial code/Invalid serial code"
          Exit Sub
     End If
          
     mSerial = CLng(Right(txbSerialCode.Text, 5))
        ' Shuffle a bit
     lngTmp = CLng(12345 * Sqr(mSerial))
     
     strTmp = CStr(lngTmp)
        ' Make string to 7-digit long
     Do While Len(strTmp) < 7
        strTmp = "0" & strTmp
     Loop
     
        ' Apply Modular 7 to get a check digit
     sumTmp = 0
     For i = Len(strTmp) To 1 Step -1
          tmp = Mid$(strTmp, i, 1)
          intTmp = CInt(tmp) * i
          sumTmp = sumTmp + intTmp
     Next i
     i = sumTmp Mod 7
     checkDigit = CStr(i)
     txbKeyCode.Text = strTmp & checkDigit
End Sub



Private Sub cmdEncryptKeyCode_Click()
     If Trim(txbSerialCode.Text) = "" Then
          MsgBox "No serial code generated yet"
          Exit Sub
     ElseIf Trim(txbKeyCode.Text) = "" Then
          MsgBox "No key code generated yet"
          Exit Sub
     End If
     txbEncryptedKeyCode.Text = EncDec(txbKeyCode.Text, txbKeyCode.Text)
End Sub



' To encrypt/decrypt a text string or a series of bytes read from a file
Function EncDec(inData As Variant, Optional inPW As Variant = "") As Variant
     On Error Resume Next
     Dim arrSBox(0 To 255) As Integer
     Dim arrPW(0 To 255) As Integer
     Dim Bi As Integer, Bj As Integer
     Dim mKey As Integer
     Dim i As Integer, j As Integer
     Dim x As Integer, y As Integer
     Dim mCode As Byte, mCodeSeries As Variant
    
     EncDec = ""
     If Trim(inData) = "" Then
         Exit Function
     End If
    
     If inPW <> "" Then
         j = 1
         For i = 0 To 255
             arrPW(i) = Asc(Mid$(inPW, j, 1))
             j = j + 1
             If j > Len(inPW) Then
                  j = 1
             End If
         Next i
     Else
         For i = 0 To 255
             arrPW(i) = 0
         Next i
     End If
     
       ' Reseed arrSBox()
     For i = 0 To 255
         arrSBox(i) = i
     Next i
     
     j = 0
     For i = 0 To 255
         j = (arrSBox(i) + arrPW(i)) Mod 256
           ' Swap
         x = arrSBox(i)
         arrSBox(i) = arrSBox(j)
         arrSBox(j) = x
     Next i
     
     mCodeSeries = ""
     Bi = 0: Bj = 0
     For i = 1 To Len(inData)
         Bi = (Bi + 1) Mod 256
         Bj = (Bj + arrSBox(Bi)) Mod 256
           ' Swap
         x = arrSBox(Bi)
         arrSBox(Bi) = arrSBox(Bj)
         arrSBox(Bj) = x
            'Generate a key
         mKey = arrSBox((arrSBox(Bi) + arrSBox(Bj)) Mod 256)
            'xor the key
         mCode = Asc(Mid$(inData, i, 1)) Xor mKey
         mCodeSeries = mCodeSeries & Chr(mCode)
     Next i
     EncDec = mCodeSeries
End Function



Private Sub cmdGetPass_Click()
     If Trim(txbSerialCode.Text) = "" Then
          MsgBox "No serial code generated yet"
          Exit Sub
     ElseIf Trim(txbKeyCode.Text) = "" Then
          MsgBox "No key code generated yet"
          Exit Sub
     ElseIf Trim(txbEncryptedKeyCode.Text) = "" Then
          MsgBox "Key code not encrypted yet"
          Exit Sub
     ElseIf txbTestPassword.Text = "" Then
          MsgBox "No password entered yet"
          Exit Sub
     End If
     
     Dim tmp
     tmp = EncDec(txbEncryptedKeyCode.Text, txbKeyCode.Text)
     
     If tmp <> txbKeyCode.Text Then
         MsgBox "Encrypted file has been tampered with; not pass"
     Else
         If txbTestPassword.Text <> txbKeyCode.Text Then
             MsgBox "Incorrect password, not pass"
             Exit Sub
         ElseIf Len(txbTestPassword.Text) <> keyCodeLen Then
             MsgBox "Incorrect password, not pass"
             Exit Sub
         End If
     End If
     MsgBox "Pass"
End Sub