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 EncryptFile(InFile As String, OutFile As String, CRC As Boolean, Optional Key As String) As Boolean

  Dim Title(1 To 2) As Byte
  Dim KeyCrc(1 To 32) As Byte
  Dim FileCrc(1 To 32) As Byte
  Dim tmp As String
  Dim Suffix() As Byte
  Dim fn As Integer, Buffer() As Byte
  Dim MD5 As clsMD5
  Dim sk As Long
  Dim i As Long
  Dim CrcTitle As Byte

    Title(1) = Asc("T")
    Title(2) = Asc("G")
    
    If Len(Dir$(OutFile)) > 0 Then
        If MsgBox("文件 " & OutFile & " 已存在,是否覆盖?", vbExclamation + vbYesNo, "文件已存在") = vbNo Then
            Exit Function
        End If
    End If
        
    If CRC Then
        CrcTitle = Asc("C")
      Else
        CrcTitle = Asc("0")
    End If
    Set MD5 = New clsMD5
    tmp = MD5.DigestStrToHexStr(Key)
    For i = 1 To 32
        KeyCrc(i) = Asc(Mid$(tmp, i, 1))
    Next i
    
    tmp = Mid$(InFile, InStrRev(InFile, ".") + 1)
    ReDim Suffix(Len(tmp))
    Suffix(0) = Len(tmp)
    For i = 1 To Suffix(0)
        Suffix(i) = Asc(Mid$(tmp, i, 1))
    Next i
        
    
    On Error GoTo errorhandler
    If FileExist(InFile) = False Then
        EncryptFile = False
        Exit Function
    End If
    'If FileExist(OutFile) = True And Overwrite = False Then
    '    EncryptFile = False
    '    Exit Function
    'End If
    fn = FreeFile                               '获取一个没有使用的文件号
    Open InFile For Binary As #fn
    ReDim Buffer(0 To LOF(fn) - 1)
    RaiseEvent Progress(0, "正在读取源文件，请稍候...")
    Get #fn, , Buffer()
    Close #fn
    Call EncryptByte(Buffer(), tmp)
    If FileExist(OutFile) = True Then Kill OutFile
    fn = FreeFile                               '获取一个没有使用的文件号
    Open OutFile For Binary As #fn
    RaiseEvent Progress(0, "正在写入目标文件，请稍候...")
    Put #fn, , Title()
    Put #fn, , CrcTitle
    Put #fn, , Suffix()
    Put #fn, , KeyCrc()
    Put #fn, , Buffer()
    sk = Seek(fn)
    If CRC Then
        RaiseEvent Progress(100, "正在添加文件效验，请稍候...")
        tmp = MD5.DigestByteToHexStr(Buffer())
        For i = 1 To 32
            FileCrc(i) = Asc(Mid$(tmp, i, 1))
        Next i
        Put #fn, , FileCrc
    End If
    Close #fn
    
    Set MD5 = Nothing
    EncryptFile = True

Exit Function

errorhandler:
    EncryptFile = False
    Set MD5 = Nothing

End Function

Public Function DecryptFile(InFile As String, OutFolder 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
  Dim OutFile As String
  Dim Filekey As String
    On Error GoTo errorhandler
    If FileExist(InFile) = False Then
        DecryptFile = False
        Exit Function
    End If
    'If FileExist(OutFile) = True 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)
    OutFile = OutFolder & Mid$(InFile, InStrRev(InFile, "\") + 1, InStrRev(InFile, ".") - InStrRev(InFile, "\")) & Suffix
    If Len(Dir$(OutFile)) > 0 Then

    End If
    ReDim Buffer(1 To 32)
    Get #fn, , Buffer()
    KeyCrc = StrConv(Buffer(), vbUnicode)
    Set MD5 = New clsMD5
    Filekey = MD5.DigestStrToHexStr(Key)
    If StrComp(KeyCrc, Filekey, 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
    If Len(Dir$(OutFile)) > 0 Then
        If MsgBox("文件 " & OutFile & " 已存在,是否覆盖?", vbExclamation + vbYesNo, "文件已存在") = vbNo Then
            Close #fn
            Exit Function
        End If
    End If
    
    Call DecryptByte(Buffer(), Filekey)

    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 Function EncryptString(Text As String, Optional Key As String, Optional OutputInHex As Boolean) As String

  Dim byteArray() As Byte

    byteArray() = StrConv(Text, vbFromUnicode)
    Call EncryptByte(byteArray(), Key)
    EncryptString = StrConv(byteArray(), vbUnicode)
    If OutputInHex = True Then EncryptString = EnHex(EncryptString)

End Function

Public Function DecryptString(Text As String, Optional Key As String, Optional IsTextInHex As Boolean) As String

  Dim byteArray() As Byte

    If IsTextInHex = True Then Text = DeHex(Text)
    byteArray() = StrConv(Text, vbFromUnicode)
    Call DecryptByte(byteArray(), Key)
    DecryptString = StrConv(byteArray(), vbUnicode)

End Function

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