clsencrypt.cls

该软件是为文本文件的数据安全性而编制的

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "dsEncrypt"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'
'说明：
'    各种通用文本文件加密算法
'日期：1999.05.13更新
'
'

Option Explicit

   Private LCW As Integer                 'Length of CodeWord
   Private LS2E As Integer                 'Length of String to be Encrypted
   Private LAM As Integer                 'Length of Array Matrix
   Private MP As Integer                    'Matrix Position
   Private Matrix As String                  'Starting Matrix
   Private mov1 As String                    'First Part of Replacement String
   Private mov2 As String                    'Second Part of Replacement String
   Private CodeWord As String            'CodeWord
   Private CWL As String                    'CodeWord Letter
   Private EncryptedString As String     'String to Return for Encrypt or String to UnEncrypt for UnEncrypt
   Private EncryptedLetter As String     'Storage Variable for Character just Encrypted
   Private strCryptMatrix(97) As String 'Matrix Array
   
Public Property Let KeyString(sKeyString As String)
    CodeWord = sKeyString
End Property

Public Function Encrypt(mstext As String) As String
    Dim x As Integer                    ' Loop Counter
    Dim Y As Integer                    'Loop Counter
    Dim Z As Integer                     'Loop Counter
    Dim C2E As String                   'Character to Encrypt
    Dim Str2Encrypt As String        'Text from TextBox

    Str2Encrypt = mstext
    LS2E = Len(mstext)
    LCW = Len(CodeWord)
    EncryptedLetter = ""
    EncryptedString = ""

    Y = 1
    For x = 1 To LS2E
        C2E = Mid(Str2Encrypt, x, 1)
        MP = InStr(1, Matrix, C2E, 0)
        CWL = Mid(CodeWord, Y, 1)
        For Z = 1 To LAM
            If Mid(strCryptMatrix(Z), MP, 1) = CWL Then
                EncryptedLetter = Left(strCryptMatrix(Z), 1)
                EncryptedString = EncryptedString + EncryptedLetter
                Exit For
            End If
        Next Z
        Y = Y + 1
        If Y > LCW Then Y = 1
    Next x
    Encrypt = EncryptedString

End Function

Private Sub Class_Initialize()

    Dim W As Integer 'Loop Counter to set up Matrix
    Dim x As Integer     'Loop through Matrix
    
    Matrix = "8x3p5BeabcdfghijklmnoqrstuvwyzACDEFGHIJKLMNOPQRSTUVWXYZ 1246790-.#/\!@$<>&*()[]{}';:,?=+~`^|%_"
    Matrix = Matrix + Chr(13)  'Add Carriage Return to Matrix
    Matrix = Matrix + Chr(10)  'Add Line Feed to Matrix
    Matrix = Matrix + Chr(34)  'Add "
    ' Unique String used to make Matrix - 8x3p5Be
    ' Unique String can be any combination that has a character only ONCE.
    ' EACH Letter in the Matrix is Input ONLY once.
    W = 1
    LAM = Len(Matrix)
    strCryptMatrix(1) = Matrix
  
    For x = 2 To LAM ' LAM = Length of Array Matrix
        mov1 = Left(strCryptMatrix(W), 1)   'First Character of strCryptMatrix
        mov2 = Right(strCryptMatrix(W), (LAM - 1))   'All but First Character of strCryptMatrix
        strCryptMatrix(x) = mov2 + mov1  'Makes up each row of the Array
        W = W + 1
    Next x
End Sub

'另一种数据加、解密方法
Public Function Encode(Data As String, Optional Depth As Integer) As String

Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Long
Dim TempCount As Long

TempCount = Len(Data) '设置进程条来显示进度长度
frmEncrypt.ProgressBar1.Max = TempCount
frmEncrypt.ProgressBar1.Visible = True '显示进程条

For vChar = 1 To TempCount
    TempChar = Mid$(Data, vChar, 1)
    TempAsc = Asc(TempChar)
    If Depth = 0 Then Depth = 40 '默认深度
    If Depth > 254 Then Depth = 254

    TempAsc = TempAsc + Depth
    If TempAsc > 255 Then TempAsc = TempAsc - 255
    TempChar = Chr(TempAsc)
    NewData = NewData & TempChar
    
    frmEncrypt.ProgressBar1.Value = vChar '进程条当前值改变
Next vChar

frmEncrypt.ProgressBar1.Visible = False '隐藏进程条

Encode = NewData

End Function

Public Function Decode(Data As String, Optional Depth As Integer) As String

Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Long
Dim TempCount As Long

TempCount = Len(Data) '设置进程条来显示进度长度
frmEncrypt.ProgressBar1.Max = TempCount
frmEncrypt.ProgressBar1.Visible = True '显示进程条

For vChar = 1 To TempCount
    TempChar = Mid$(Data, vChar, 1)
    TempAsc = Asc(TempChar)
    If Depth = 0 Then Depth = 40 '默认深度
    If Depth > 254 Then Depth = 254
    
    TempAsc = TempAsc - Depth
    If TempAsc < 0 Then TempAsc = TempAsc + 255
    TempChar = Chr(TempAsc)
    NewData = NewData & TempChar
    
    frmEncrypt.ProgressBar1.Value = vChar '进程条当前值改变
Next vChar

frmEncrypt.ProgressBar1.Visible = False '隐藏进程条

Decode = NewData

End Function

'加入RLE压缩算法（压缩重复字符）
Public Function RLEDecode(InputString As String) As String

    Dim RLEString As String
    Dim TextString As String
    Dim x As Integer
    
    For x = 1 To Len(InputString)
        ThisChar = Mid$(InputString, x, 1)
        If ThisChar = "~" Then
            TextString = TextString & String$(Asc(Mid$(InputString, x + 1, 1)), PrevChar)
            x = x + 1
        Else
            TextString = TextString & ThisChar
        End If
        
        PrevChar = ThisChar
    Next x
    
    RLEDecode = TextString

End Function

Public Function RLEEncode(InputString As String) As String

    Dim LastChar As String
    Dim ThisChar As String
    Dim RLEString As String
    Dim DupeChar As String
    Dim x As Integer
    Dim RepeatCount As Integer
    
    RepeatCount = 0
    For x = 1 To Len(InputString)
        ThisChar = Mid$(InputString, x, 1)
        If LastChar = ThisChar Then
            
            'If there is only 1 repeating (like the e in Cheese)
            'then don't encode
            'because it will take 1 extra byte
            If Mid$(InputString$, x + 1, 1) <> ThisChar And _
                RepeatCount = 0 Then
                RLEString = RLEString & ThisChar
                LastChar = ThisChar
            Else
                RepeatCount = RepeatCount + 1
        
                'We can only encode up to 254 repeats after that
                'we have to start the new sequence again
                If RepeatCount = 254 Then
                    RLEString = RLEString & "~" & Chr$(RepeatCount)
                    RepeatCount = 0
                    LastChar = ""
                End If
            End If
        Else
            If RepeatCount > 0 Then
                RLEString = RLEString & "~" & Chr$(RepeatCount)
                RepeatCount = 0
            End If
    
            RLEString = RLEString & ThisChar
            LastChar = ThisChar
        End If
    Next x
    
    'If the last chars in string are repeats
    If RepeatCount > 0 Then
        RLEString = RLEString & "~" & Chr$(RepeatCount)
        RepeatCount = 0
    End If
    
    RLEEncode = RLEString

End Function