en.cls

来自「vb写的密码设置、修改系统」· CLS 代码 · 共 151 行

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsEncrypter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'Encrypter.CLS
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'how to Encrypt/Decrypt?
'First Step:
'Encrypter.KeyString=CodeOrKey$
'Second Step:
'Encrypter.Text=StringToEncrypt$
'Main Steps For Encrypt:~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'Third Step (For Encrypt):
    'Encrypter.DoXor
    'Fourth Step (For Encrypt):
    'Encrypter.Stretch
    'Fourth Step (For Encrypt):
    'EncryptedText$=Encrypter.Text
'Main Steps For Decrypt:~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'Third Step (For Encrypt):
    'Encrypter.Shrink
    'Fourth Step (For Decrypt):
    'Encrypter.DoXor
    'DecryptedText$=Encrypter.Text
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Private mstrKey As String
Private mstrText As String

'~~~.KeyString
Public Property Let KeyString(strKey As String)
    mstrKey = strKey
    Initialize
End Property

'~~~.Text
Public Property Let text(strText As String)
    mstrText = strText
End Property

Public Property Get text() As String
    text = mstrText
End Property

'~~~.DoXor
Public Sub DoXor()
    Dim lngC As Currency
    Dim intB As Currency
    Dim lngN As Currency
    For lngN = 1 To Len(mstrText)
        lngC = Asc(Mid(mstrText, lngN, 1))
        intB = Int(Rnd(-1985) * 256)
        Mid(mstrText, lngN, 1) = Chr(lngC Xor intB)
    Next lngN
End Sub

'~~~.Stretch
'Convert any string to a printable, displayable string
Public Sub Stretch()
    Dim lngC As Currency
    Dim lngN As Currency
    Dim lngJ As Currency
    Dim lngK As Currency
    Dim lngA As Currency
    Dim strB As String
    lngA = Len(mstrText)
    strB = Space(lngA + (lngA + 2) \ 3)
    For lngN = 1 To lngA
        lngC = Asc(Mid(mstrText, lngN, 1))
        lngJ = lngJ + 1
        Mid(strB, lngJ, 1) = Chr((lngC And 63) + 59)
        Select Case lngN Mod 3
        Case 1
            lngK = lngK Or ((lngC \ 64) * 16)
        Case 2
            lngK = lngK Or ((lngC \ 64) * 4)
        Case 0
            lngK = lngK Or (lngC \ 64)
            lngJ = lngJ + 1
            Mid(strB, lngJ, 1) = Chr(lngK + 59)
            lngK = 0
        End Select
    Next lngN
    If lngA Mod 3 Then
        lngJ = lngJ + 1
        Mid(strB, lngJ, 1) = Chr(lngK + 59)
    End If
    mstrText = strB
End Sub

'~~~.Shrink
'Inverse of the Stretch method;
Public Sub Shrink()
    Dim lngC As Currency
    Dim lngD As Currency
    Dim lngE As Currency
    Dim lngA As Currency
    Dim lngB As Currency
    Dim lngN As Currency
    Dim lngJ As Currency
    Dim lngK As Currency
    Dim strB As String
    lngA = Len(mstrText)
    lngB = lngA - 1 - (lngA - 1) \ 4
    strB = Space(lngB)
    For lngN = 1 To lngB
        lngJ = lngJ + 1
        lngC = Asc(Mid(mstrText, lngJ, 1)) - 59
        Select Case lngN Mod 3
        Case 1
            lngK = lngK + 4
            If lngK > lngA Then lngK = lngA
            lngE = Asc(Mid(mstrText, lngK, 1)) - 59
            lngD = ((lngE \ 16) And 3) * 64
        Case 2
            lngD = ((lngE \ 4) And 3) * 64
        Case 0
            lngD = (lngE And 3) * 64
            lngJ = lngJ + 1
        End Select
        On Error GoTo 1
        Mid(strB, lngN, 1) = Chr(lngC Or lngD)
    Next lngN
    mstrText = strB
    Exit Sub
1 If Err.Number = 5 Then
MsgBox "Error in decrypt process!"
    End If
End Sub

'Initializes random numbers using the key string
Private Sub Initialize()
    Dim lngN As Long
    Randomize Rnd(-1)
    For lngN = 1 To Len(mstrKey)
        Randomize Rnd(-1 * (Rnd(-22) * Asc(Mid(mstrKey, lngN, 1))))
    Next lngN
End Sub