clsrc4.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 = "clsRC4"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' Visual Basic RC4 Implementation
' David Midkiff ([e-mail])
'
' Standard RC4 implementation with file support, hex conversion,
' speed string concatenation and overall optimisations for Visual Basic.
' RC4 is an extremely fast and very secure stream cipher from RSA Data
' Security, Inc. I recommend this for high risk low resource environments.
' It's speed is very very attractive. Patents do apply for commercial use.
'
' Information on the algorithm can be found at:
' http://www.rsasecurity.com/rsalabs/faq/3-6-3.html

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Event Progress(Percent As Long, State As String)

Private m_Key As String
Private m_sBox(0 To 255) As Integer
Private byteArray() As Byte
Private hiByte As Long
Private hiBound As Long

Public Function DecryptFile(InFile As String, OutFile As String, Optional Key As String) As Boolean

  Dim KeyCrc As String
  Dim FileCrc As String
  Dim tmp() As Byte
  Dim Suffix As String
  Dim fn As Integer, Buffer() As Byte
  Dim MD5 As clsMD5
  Dim i As Long
  Dim CrcTitle As Boolean

    On Error GoTo errorhandler
    If FileExist(InFile) = False Then
        DecryptFile = False
        Exit Function
    End If
    fn = FreeFile
    Open InFile For Binary As #fn
    
    ReDim tmp(0 To 1)
    Get #fn, , tmp()
    If StrComp(StrConv(tmp, vbUnicode), "TG", vbBinaryCompare) <> 0 Then
        MsgBox "文件 " & InFile & "不是使用本软件加密的文件!", vbCritical, "文件错误"
        DecryptFile = False
        Close #fn
        Exit Function
    End If
        
    ReDim tmp(1 To 2)
    Get #fn, , tmp()
    CrcTitle = Chr$(tmp(1)) = "C"
    ReDim Buffer(1 To tmp(2))
        
    Get #fn, , Buffer()
    Suffix = StrConv(Buffer(), vbUnicode)
       
    ReDim Buffer(1 To 32)
    Get #fn, , Buffer()
    KeyCrc = StrConv(Buffer(), vbUnicode)
    Set MD5 = New clsMD5
    If StrComp(KeyCrc, MD5.DigestStrToHexStr(Key), vbBinaryCompare) <> 0 Then
        MsgBox "文件 " & InFile & " 的密码错误！", vbCritical, "密码错误"
        Close #fn
        Exit Function
    End If
        
    If CrcTitle Then
        ReDim tmp(1 To 32)
        ReDim Buffer(LOF(fn) - 32 - Seek(fn))
        Get #fn, , Buffer()
        Get #fn, , tmp()
        FileCrc = StrConv(tmp(), vbUnicode)
            
        If StrComp(FileCrc, MD5.DigestByteToHexStr(Buffer())) <> 0 Then
            MsgBox "文件 " & InFile & "效验错误，文件被改动过。", vbCritical, "效验错误"
            Close #fn
            Exit Function
        End If
      Else
        ReDim Buffer(LOF(fn) - Seek(fn))
        Get #fn, , Buffer()
    End If
    Close #fn
    Call DecryptByte(Buffer(), Key)
    If FileExist(OutFile) = True Then Kill OutFile
    fn = FreeFile
    Open OutFile For Binary As #fn
    Put #fn, , Buffer()
    Close #fn
    DecryptFile = True
    Set MD5 = Nothing

Exit Function

errorhandler:
    DecryptFile = False
    Set MD5 = Nothing

End Function

Public Sub DecryptByte(byteArray() As Byte, Optional Key As String)

    Call EncryptByte(byteArray(), Key)

End Sub

Public Sub EncryptByte(byteArray() As Byte, Optional Key As String)

  Dim i As Long, j As Long, Temp As Byte, Offset As Long, OrigLen As Long, CipherLen As Long, CurrPercent As Long, NextPercent As Long, sBox(0 To 255) As Integer

    If (Len(Key) > 0) Then Me.Key = Key
    Call CopyMem(sBox(0), m_sBox(0), 512)
    OrigLen = UBound(byteArray) + 1
    CipherLen = OrigLen

    For Offset = 0 To (OrigLen - 1)
        i = (i + 1) Mod 256
        j = (j + sBox(i)) Mod 256
        Temp = sBox(i)
        sBox(i) = sBox(j)
        sBox(j) = Temp
        byteArray(Offset) = byteArray(Offset) Xor (sBox((sBox(i) + sBox(j)) Mod 256))
        If (Offset >= NextPercent) Then
            CurrPercent = Int((Offset / CipherLen) * 100)
            NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1
            RaiseEvent Progress(CurrPercent, "正在处理数据，请稍候...")
        End If
    Next Offset
    If (CurrPercent <> 100) Then RaiseEvent Progress(100, "完成。")

End Sub

Private Sub Reset()

    hiByte = 0
    hiBound = 1024
    ReDim byteArray(hiBound)

End Sub

Private Sub Append(ByRef StringData As String, Optional Length As Long)

  Dim DataLength As Long

    If Length > 0 Then DataLength = Length Else DataLength = Len(StringData)
    If DataLength + hiByte > hiBound Then
        hiBound = hiBound + 1024
        ReDim Preserve byteArray(hiBound)
    End If
    CopyMem ByVal VarPtr(byteArray(hiByte)), ByVal StringData, DataLength
    hiByte = hiByte + DataLength

End Sub

Private Function DeHex(data As String) As String

  Dim iCount As Double

    Reset
    For iCount = 1 To Len(data) Step 2
        Append Chr$(Val("&H" & Mid$(data, iCount, 2)))
    Next iCount
    DeHex = GData
    Reset

End Function

Private Function EnHex(data As String) As String

  Dim iCount As Double, sTemp As String

    Reset
    For iCount = 1 To Len(data)
        sTemp = Hex$(Asc(Mid$(data, iCount, 1)))
        If Len(sTemp) < 2 Then sTemp = "0" & sTemp
        Append sTemp
    Next iCount
    EnHex = GData
    Reset

End Function

Private Function FileExist(FileName As String) As Boolean

    On Error GoTo errorhandler
    Call FileLen(FileName)
    FileExist = True

Exit Function

errorhandler:
    FileExist = False

End Function

Private Property Get GData() As String

  Dim StringData As String

    StringData = Space(hiByte)
    CopyMem ByVal StringData, ByVal VarPtr(byteArray(0)), hiByte
    GData = StringData

End Property

Public Property Let Key(New_Value As String)

  Dim A As Long, B As Long, Temp As Byte, Key() As Byte, KeyLen As Long

    If (m_Key = New_Value) Then Exit Property
    m_Key = New_Value
    Key() = StrConv(m_Key, vbFromUnicode)
    KeyLen = Len(m_Key)
    For A = 0 To 255
        m_sBox(A) = A
    Next A
    For A = 0 To 255
        B = (B + m_sBox(A) + Key(A Mod KeyLen)) Mod 256
        Temp = m_sBox(A)
        m_sBox(A) = m_sBox(B)
        m_sBox(B) = Temp
    Next A

End Property