clstwofish.cls

经典加解密 代码源码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsTwofish"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'Twofish Encryption/Decryption Class
'------------------------------------
'
'Information concerning the Twofish
'algorithm can be found at:
'http://www.counterpane.com/twofish.html
'
'(c) 2000, Fredrik Qvarfort
'

Option Explicit

'For progress notifications
Event Progress(Percent As Long)

Public Enum TWOFISHKEYLENGTH
  TWOFISH_256 = 256
  TWOFISH_196 = 196
  TWOFISH_128 = 128
  TWOFISH_64 = 64
End Enum

Private Const ROUNDS = 16
Private Const BLOCK_SIZE = 16
Private Const MAX_ROUNDS = 16
   
Private Const INPUT_WHITEN = 0
Private Const OUTPUT_WHITEN = INPUT_WHITEN + BLOCK_SIZE / 4
Private Const ROUND_SUBKEYS = OUTPUT_WHITEN + BLOCK_SIZE / 4

Private Const GF256_FDBK_2 = &H169 / 2
Private Const GF256_FDBK_4 = &H169 / 4

Private MDS(0 To 3, 0 To 255) As Long
Private P(0 To 1, 0 To 255) As Byte

Private m_RunningCompiled As Boolean

'Key-dependant data
Private sBox(0 To 1023) As Long
Private sKey() As Long

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

Public Sub EncryptFile(SourceFile As String, DestFile As String, Optional Key As String)

  Dim Filenr As Integer
  Dim ByteArray() As Byte
  
  'Make sure the source file do exist
  If (Not FileExist(SourceFile)) Then
    Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).")
    Exit Sub
  End If
  
  'Open the source file and read the content
  'into a bytearray to pass onto encryption
  Filenr = FreeFile
  Open SourceFile For Binary As #Filenr
  ReDim ByteArray(0 To LOF(Filenr) - 1)
  Get #Filenr, , ByteArray()
  Close #Filenr
  
  'Encrypt the bytearray
  Call EncryptByte(ByteArray(), Key)

  'If the destination file already exist we need
  'to delete it since opening it for binary use
  'will preserve it if it already exist
  If (FileExist(DestFile)) Then Kill DestFile
  
  'Store the encrypted data in the destination file
  Filenr = FreeFile
  Open DestFile For Binary As #Filenr
  Put #Filenr, , ByteArray()
  Close #Filenr

End Sub

Public Sub DecryptFile(SourceFile As String, DestFile As String, Optional Key As String)

  Dim Filenr As Integer
  Dim ByteArray() As Byte
  
  'Make sure the source file do exist
  If (Not FileExist(SourceFile)) Then
    Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).")
    Exit Sub
  End If
  
  'Open the source file and read the content
  'into a bytearray to decrypt
  Filenr = FreeFile
  Open SourceFile For Binary As #Filenr
  ReDim ByteArray(0 To LOF(Filenr) - 1)
  Get #Filenr, , ByteArray()
  Close #Filenr
  
  'Decrypt the bytearray
  Call DecryptByte(ByteArray(), Key)

  'If the destination file already exist we need
  'to delete it since opening it for binary use
  'will preserve it if it already exist
  If (FileExist(DestFile)) Then Kill DestFile

  'Store the decrypted data in the destination file
  Filenr = FreeFile
  Open DestFile For Binary As #Filenr
  Put #Filenr, , ByteArray()
  Close #Filenr

End Sub

Public Function EncryptString(Text As String, Optional Key As String) As String

  Dim ByteArray() As Byte
  
  'Convert the string to a bytearray
  ByteArray() = StrConv(Text, vbFromUnicode)
  
  'Encrypt the array
  Call EncryptByte(ByteArray(), Key)
  
  'Return the encrypted data as a string
  EncryptString = StrConv(ByteArray(), vbUnicode)

End Function
Public Function DecryptString(Text As String, Optional Key As String) As String

  Dim ByteArray() As Byte
  
  'Convert the string to a bytearray
  ByteArray() = StrConv(Text, vbFromUnicode)
  
  'Encrypt the array
  Call DecryptByte(ByteArray(), Key)
  
  'Return the encrypted data as a string
  DecryptString = StrConv(ByteArray(), vbUnicode)

End Function

Private Static Function LFSR1(ByRef x As Long) As Long
   
  LFSR1 = lBSR(x, 1) Xor ((x And 1) * GF256_FDBK_2)

End Function
Private Static Function LFSR2(ByRef x As Long) As Long
    
  LFSR2 = lBSR(x, 2) Xor ((x And &H2) / &H2 * GF256_FDBK_2) Xor ((x And &H1) * GF256_FDBK_4)

End Function
Private Static Function RS_Rem(x As Long) As Long
  
  Dim b As Long
  Dim g2 As Long
  Dim g3 As Long
  
  b = (lBSRU(x, 24) And &HFF)
  g2 = ((lBSL(b, 1) Xor (b And &H80) / &H80 * &H14D) And &HFF)
  g3 = (lBSRU(b, 1) Xor ((b And &H1) * lBSRU(&H14D, 1)) Xor g2)
  RS_Rem = lBSL(x, 8) Xor lBSL(g3, 24) Xor lBSL(g2, 16) Xor lBSL(g3, 8) Xor b

End Function


Private Static Function F32(k64Cnt As Long, x As Long, k32() As Long) As Long
  
  Dim xb(0 To 3) As Byte
  Dim Key(0 To 3, 0 To 3) As Byte
  
  Call CopyMem(xb(0), x, 4)
  Call CopyMem(Key(0, 0), k32(0), 16)
  
  If ((k64Cnt And 3) = 1) Then
    F32 = MDS(0, P(0, xb(0)) Xor Key(0, 0)) Xor _
          MDS(1, P(0, xb(1)) Xor Key(1, 0)) Xor _
          MDS(2, P(1, xb(2)) Xor Key(2, 0)) Xor _
          MDS(3, P(1, xb(3)) Xor Key(3, 0))
  Else
    If ((k64Cnt And 3) = 0) Then
      xb(0) = P(1, xb(0)) Xor Key(0, 3)
      xb(1) = P(0, xb(1)) Xor Key(1, 3)
      xb(2) = P(0, xb(2)) Xor Key(2, 3)
      xb(3) = P(1, xb(3)) Xor Key(3, 3)
    End If
    If ((k64Cnt And 3) = 3) Or ((k64Cnt And 3) = 0) Then
      xb(0) = P(1, xb(0)) Xor Key(0, 2)
      xb(1) = P(1, xb(1)) Xor Key(1, 2)
      xb(2) = P(0, xb(2)) Xor Key(2, 2)
      xb(3) = P(0, xb(3)) Xor Key(3, 2)
    End If
    F32 = MDS(0, P(0, P(0, xb(0)) Xor Key(0, 1)) Xor Key(0, 0)) Xor _
          MDS(1, P(0, P(1, xb(1)) Xor Key(1, 1)) Xor Key(1, 0)) Xor _
          MDS(2, P(1, P(0, xb(2)) Xor Key(2, 1)) Xor Key(2, 0)) Xor _
          MDS(3, P(1, P(1, xb(3)) Xor Key(3, 1)) Xor Key(3, 0))
  End If
  
End Function
Private Static Function Fe32(x As Long, R As Long) As Long
  
  Dim xb(0 To 3) As Byte
  
  'Extract the byte sequence
  Call CopyMem(xb(0), x, 4)
  
  'Calculate the FE32 function
  Fe32 = sBox(2 * xb(R Mod 4)) Xor _
         sBox(2 * xb((R + 1) Mod 4) + 1) Xor _
         sBox(&H200 + 2 * xb((R + 2) Mod 4)) Xor _
         sBox(&H200 + 2 * xb((R + 3) Mod 4) + 1)

End Function
Private Static Sub KeyCreate(K() As Byte, KeyLength As Long)
  
  Dim i As Long
  Dim lA As Long
  Dim lB As Long
  Dim b(3) As Byte
  Dim k64Cnt As Long
  Dim k32e(3) As Long
  Dim k32o(3) As Long
  Dim subkeyCnt As Long
  Dim sBoxKey(3) As Long
  Dim Key(0 To 3, 0 To 3) As Byte
  
  Const SK_STEP = &H2020202
  Const SK_BUMP = &H1010101
  Const SK_ROTL = 9
  
  k64Cnt = KeyLength \ 8
  subkeyCnt = ROUND_SUBKEYS + 2 * ROUNDS
  
  For i = 0 To IIf(KeyLength < 32, KeyLength \ 8 - 1, 3)
    Call CopyMem(k32e(i), K(i * 8), 4)
    Call CopyMem(k32o(i), K(i * 8 + 4), 4)
    sBoxKey(KeyLength \ 8 - 1 - i) = RS_Rem(RS_Rem(RS_Rem(RS_Rem(RS_Rem(RS_Rem(RS_Rem(RS_Rem(k32o(i))))) Xor k32e(i)))))
  Next
  
  ReDim sKey(subkeyCnt)
  For i = 0 To ((subkeyCnt / 2) - 1)
    lA = F32(k64Cnt, i * SK_STEP, k32e)
    lB = F32(k64Cnt, i * SK_STEP + SK_BUMP, k32o)
    lB = lBSL(lB, 8) Or lBSRU(lB, 24)
    If (m_RunningCompiled) Then
      lA = lA + lB
    Else
      lA = UnsignedAdd(lA, lB)
    End If
    sKey(2 * i) = lA
    If (m_RunningCompiled) Then
      lA = lA + lB
    Else
      lA = UnsignedAdd(lA, lB)
    End If
    sKey(2 * i + 1) = lBSL(lA, SK_ROTL) Or lBSRU(lA, 32 - SK_ROTL)
  Next
  
  Call CopyMem(Key(0, 0), sBoxKey(0), 16)
  
  For i = 0 To 255
    If ((k64Cnt And 3) = 1) Then
      sBox(2 * i) = MDS(0, P(0, i) Xor Key(0, 0))
      sBox(2 * i + 1) = MDS(1, P(0, i) Xor Key(1, 0))
      sBox(&H200 + 2 * i) = MDS(2, P(1, i) Xor Key(2, 0))
      sBox(&H200 + 2 * i + 1) = MDS(3, P(1, i) Xor Key(3, 0))
    Else
      b(0) = i
      b(1) = i
      b(2) = i
      b(3) = i
      If ((k64Cnt And 3) = 0) Then
        b(0) = P(1, b(0)) Xor Key(0, 3)
        b(1) = P(0, b(1)) Xor Key(1, 3)
        b(2) = P(0, b(2)) Xor Key(2, 3)
        b(3) = P(1, b(3)) Xor Key(3, 3)
      End If
      If ((k64Cnt And 3) = 3) Or ((k64Cnt And 3) = 0) Then '(exception = True) Then
        b(0) = P(1, b(0)) Xor Key(0, 2)
        b(1) = P(1, b(1)) Xor Key(1, 2)
        b(2) = P(0, b(2)) Xor Key(2, 2)
        b(3) = P(0, b(3)) Xor Key(3, 2)
      End If
      sBox(2 * i) = MDS(0, P(0, P(0, b(0)) Xor Key(0, 1)) Xor Key(0, 0))
      sBox(2 * i + 1) = MDS(1, P(0, P(1, b(1)) Xor Key(1, 1)) Xor Key(1, 0))
      sBox(&H200 + 2 * i) = MDS(2, P(1, P(0, b(2)) Xor Key(2, 1)) Xor Key(2, 0))
      sBox(&H200 + 2 * i + 1) = MDS(3, P(1, P(1, b(3)) Xor Key(3, 1)) Xor Key(3, 0))
    End If
  Next
  
End Sub
Private Function lBSL(ByRef lInput As Long, ByRef bShiftBits As Byte) As Long
  
  lBSL = (lInput And (2 ^ (31 - bShiftBits) - 1)) * 2 ^ bShiftBits
  If (lInput And 2 ^ (31 - bShiftBits)) = 2 ^ (31 - bShiftBits) Then lBSL = (lBSL Or &H80000000)

End Function
Private Function lBSR(ByRef lInput As Long, ByRef bShiftBits As Byte) As Long
  
  If (bShiftBits = 31) Then
    If (lInput < 0) Then lBSR = &HFFFFFFFF Else lBSR = 0
  Else
    lBSR = (lInput And Not (2 ^ bShiftBits - 1)) \ 2 ^ bShiftBits
  End If

End Function

Private Function lBSRU(lInput As Long, bShiftBits As Byte) As Long
  
  If (bShiftBits = 31) Then
    lBSRU = -(lInput < 0)
  Else
    lBSRU = (((lInput And Not (2 ^ bShiftBits - 1)) \ 2 ^ bShiftBits) And Not (&H80000000 + (2 ^ bShiftBits - 2) * 2 ^ (31 - bShiftBits)))
  End If

End Function

Private Static Sub EncryptBlock(DWord() As Long)
  
  Dim t0 As Long
  Dim t1 As Long
  Dim K As Long
  Dim R As Long
  
  DWord(0) = DWord(0) Xor sKey(INPUT_WHITEN)
  DWord(1) = DWord(1) Xor sKey(INPUT_WHITEN + 1)
  DWord(2) = DWord(2) Xor sKey(INPUT_WHITEN + 2)
  DWord(3) = DWord(3) Xor sKey(INPUT_WHITEN + 3)
  
  K = ROUND_SUBKEYS
  For R = 0 To (ROUNDS - 1) Step 2
    If (m_RunningCompiled) Then
      'This is the algorithm when run in compiled
      'mode, where VB won't raise overflow errors
      t0 = Fe32(DWord(0), 0)
      t1 = Fe32(DWord(1), 3)
      t0 = t0 + t1
      DWord(2) = Rot1(DWord(2) Xor (t0 + sKey(K)))
      K = K + 1
      DWord(3) = Rot31(DWord(3)) Xor (t0 + t1 + sKey(K))
      K = K + 1
      t0 = Fe32(DWord(2), 0)
      t1 = Fe32(DWord(3), 3)
      t0 = t0 + t1
      DWord(0) = Rot1(DWord(0) Xor (t0 + sKey(K)))
      K = K + 1
      DWord(1) = Rot31(DWord(1)) Xor (t0 + t1 + sKey(K))
      K = K + 1
    Else
      'This is the algorithm when running in the IDE,
      'although it's slower it makes the code able
      'to run in the IDE without overflow errors
      t0 = Fe32(DWord(0), 0)
      t1 = Fe32(DWord(1), 3)
      t0 = UnsignedAdd(t0, t1)
      DWord(2) = Rot1(DWord(2) Xor (UnsignedAdd(t0, sKey(K))))
      K = K + 1
      DWord(3) = Rot31(DWord(3)) Xor (UnsignedAdd(UnsignedAdd(t0, t1), sKey(K)))
      K = K + 1
      t0 = Fe32(DWord(2), 0)
      t1 = Fe32(DWord(3), 3)
      t0 = UnsignedAdd(t0, t1)
      DWord(0) = Rot1(DWord(0) Xor (UnsignedAdd(t0, sKey(K))))
      K = K + 1
      DWord(1) = Rot31(DWord(1)) Xor (UnsignedAdd(UnsignedAdd(t0, t1), sKey(K)))
      K = K + 1
    End If
  Next

  DWord(2) = DWord(2) Xor sKey(OUTPUT_WHITEN)
  DWord(3) = DWord(3) Xor sKey(OUTPUT_WHITEN + 1)
  DWord(4) = DWord(0) Xor sKey(OUTPUT_WHITEN + 2)
  DWord(5) = DWord(1) Xor sKey(OUTPUT_WHITEN + 3)
  Call CopyMem(DWord(0), DWord(2), 16)

End Sub
Private Sub DecryptBlock(DWord() As Long)
    
  Dim K As Long
  Dim R As Long
  Dim t0 As Long
  Dim t1 As Long
  
  DWord(2) = DWord(2) Xor sKey(OUTPUT_WHITEN)
  DWord(3) = DWord(3) Xor sKey(OUTPUT_WHITEN + 1)
  DWord(0) = DWord(4) Xor sKey(OUTPUT_WHITEN + 2)
  DWord(1) = DWord(5) Xor sKey(OUTPUT_WHITEN + 3)

  K = ROUND_SUBKEYS + 2 * ROUNDS - 1
  For R = 0 To ROUNDS - 1 Step 2
    If (m_RunningCompiled) Then
      t0 = Fe32(DWord(2), 0)
      t1 = Fe32(DWord(3), 3)
      t0 = t0 + t1
      DWord(1) = Rot1(DWord(1) Xor (t0 + t1 + sKey(K)))
      K = K - 1
      DWord(0) = Rot31(DWord(0)) Xor (t0 + sKey(K))
      K = K - 1
      t0 = Fe32(DWord(0), 0)
      t1 = Fe32(DWord(1), 3)
      t0 = t0 + t1
      DWord(3) = Rot1(DWord(3) Xor (t0 + t1 + sKey(K)))
      K = K - 1
      DWord(2) = Rot31(DWord(2)) Xor (t0 + sKey(K))
      K = K - 1
    Else
      t0 = Fe32(DWord(2), 0)
      t1 = Fe32(DWord(3), 3)
      t0 = UnsignedAdd(t0, t1)
      DWord(1) = Rot1(DWord(1) Xor (UnsignedAdd(UnsignedAdd(t0, t1), sKey(K))))
      K = K - 1
      DWord(0) = Rot31(DWord(0)) Xor (UnsignedAdd(t0, sKey(K)))
      K = K - 1
      t0 = Fe32(DWord(0), 0)
      t1 = Fe32(DWord(1), 3)
      t0 = UnsignedAdd(t0, t1)
      DWord(3) = Rot1(DWord(3) Xor (UnsignedAdd(UnsignedAdd(t0, t1), sKey(K))))
      K = K - 1
      DWord(2) = Rot31(DWord(2)) Xor (UnsignedAdd(t0, sKey(K)))
      K = K - 1
    End If
  Next
    
  DWord(0) = DWord(0) Xor sKey(INPUT_WHITEN)
  DWord(1) = DWord(1) Xor sKey(INPUT_WHITEN + 1)
  DWord(2) = DWord(2) Xor sKey(INPUT_WHITEN + 2)
  DWord(3) = DWord(3) Xor sKey(INPUT_WHITEN + 3)

End Sub
Private Static Function Rot1(Value As Long) As Long

  Dim Temp As Byte
  Dim x(0 To 3) As Byte
  
  Call CopyMem(x(0), Value, 4)
  
  Temp = x(0)
  x(0) = (x(0) \ 2) Or ((x(1) And 1) * 128)
  x(1) = (x(1) \ 2) Or ((x(2) And 1) * 128)
  x(2) = (x(2) \ 2) Or ((x(3) And 1) * 128)
  x(3) = (x(3) \ 2) Or ((Temp And 1) * 128)
  
  Call CopyMem(Rot1, x(0), 4)
  
End Function
Private Static Function Rot31(Value As Long) As Long

  Dim Temp As Byte
  Dim x(0 To 3) As Byte
  
  Call CopyMem(x(0), Value, 4)
  
  Temp = x(3)
  x(3) = ((x(3) And 127) * 2) Or -CBool(x(2) And 128)
  x(2) = ((x(2) And 127) * 2) Or -CBool(x(1) And 128)
  x(1) = ((x(1) And 127) * 2) Or -CBool(x(0) And 128)
  x(0) = ((x(0) And 127) * 2) Or -CBool(Temp And 128)
  
  Call CopyMem(Rot31, x(0), 4)
  
End Function

Private Sub Class_Initialize()
  
  Dim i As Long
  Dim j As Long
  Dim m1(0 To 1) As Long
  Dim mX(0 To 1) As Long
  Dim mY(0 To 1) As Long
  
  'We need to check if we are running in compiled
  '(EXE) mode or in the IDE, this will allow us to
  'use optimized code with unsigned integers in
  'compiled mode without any overflow errors when
  'running the code in the IDE
  On Local Error Resume Next
  m_RunningCompiled = ((2147483647 + 1) < 0)
  
  'Initialize P(0,..) array
  P(0, 0) = &HA9
  P(0, 1) = &H67
  P(0, 2) = &HB3
  P(0, 3) = &HE8
  P(0, 4) = &H4
  P(0, 5) = &HFD
  P(0, 6) = &HA3
  P(0, 7) = &H76
  P(0, 8) = &H9A
  P(0, 9) = &H92
  P(0, 10) = &H80
  P(0, 11) = &H78
  P(0, 12) = &HE4
  P(0, 13) = &HDD
  P(0, 14) = &HD1
  P(0, 15) = &H38
  P(0, 16) = &HD
  P(0, 17) = &HC6
  P(0, 18) = &H35
  P(0, 19) = &H98
  P(0, 20) = &H18
  P(0, 21) = &HF7
  P(0, 22) = &HEC
  P(0, 23) = &H6C
  P(0, 24) = &H43
  P(0, 25) = &H75
  P(0, 26) = &H37
  P(0, 27) = &H26
  P(0, 28) = &HFA
  P(0, 29) = &H13
  P(0, 30) = &H94
  P(0, 31) = &H48
  P(0, 32) = &HF2
  P(0, 33) = &HD0
  P(0, 34) = &H8B
  P(0, 35) = &H30
  P(0, 36) = &H84
  P(0, 37) = &H54
  P(0, 38) = &HDF
  P(0, 39) = &H23
  P(0, 40) = &H19
  P(0, 41) = &H5B
  P(0, 42) = &H3D
  P(0, 43) = &H59
  P(0, 44) = &HF3
  P(0, 45) = &HAE
  P(0, 46) = &HA2
  P(0, 47) = &H82
  P(0, 48) = &H63
  P(0, 49) = &H1
  P(0, 50) = &H83
  P(0, 51) = &H2E
  P(0, 52) = &HD9
  P(0, 53) = &H51
  P(0, 54) = &H9B
  P(0, 55) = &H7C
  P(0, 56) = &HA6
  P(0, 57) = &HEB
  P(0, 58) = &HA5
  P(0, 59) = &HBE
  P(0, 60) = &H16
  P(0, 61) = &HC
  P(0, 62) = &HE3
  P(0, 63) = &H61
  P(0, 64) = &HC0
  P(0, 65) = &H8C
  P(0, 66) = &H3A
  P(0, 67) = &HF5
  P(0, 68) = &H73
  P(0, 69) = &H2C
  P(0, 70) = &H25
  P(0, 71) = &HB
  P(0, 72) = &HBB
  P(0, 73) = &H4E
  P(0, 74) = &H89
  P(0, 75) = &H6B
  P(0, 76) = &H53
  P(0, 77) = &H6A
  P(0, 78) = &HB4
  P(0, 79) = &HF1
  P(0, 80) = &HE1
  P(0, 81) = &HE6
  P(0, 82) = &HBD
  P(0, 83) = &H45
  P(0, 84) = &HE2
  P(0, 85) = &HF4
  P(0, 86) = &HB6
  P(0, 87) = &H66
  P(0, 88) = &HCC
  P(0, 89) = &H95
  P(0, 90) = &H3
  P(0, 91) = &H56
  P(0, 92) = &HD4
  P(0, 93) = &H1C
  P(0, 94) = &H1E
  P(0, 95) = &HD7
  P(0, 96) = &HFB
  P(0, 97) = &HC3
  P(0, 98) = &H8E
  P(0, 99) = &HB5
  P(0, 100) = &HE9
  P(0, 101) = &HCF
  P(0, 102) = &HBF
  P(0, 103) = &HBA
  P(0, 104) = &HEA
  P(0, 105) = &H77
  P(0, 106) = &H39
  P(0, 107) = &HAF
  P(0, 108) = &H33
  P(0, 109) = &HC9