clsblowfish.cls

加密的模块包含了大多数的加密拴法 可以下载

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

Option Explicit

'For progress notifications
Event Progress(Percent As Long)

'Constant for number of rounds
Private Const ROUNDS = 16

'Keydependant p-boxes and s-boxes
Private m_pBox(0 To ROUNDS + 1) As Long
Private m_sBox(0 To 3, 0 To 255) As Long

'Store buffered key
Private m_KeyValue As String

'To be able to run optimized code (addition
'without the slow UnsignedAdd procedure we
'need to know if we are running in compiled
'mode or in the IDE)
Private m_RunningCompiled As Boolean

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

  Dim i As Long
  Dim j As Long
  Dim Temp As Long
  
  Temp = Xr
  Xr = Xl Xor m_pBox(ROUNDS + 1)
  Xl = Temp Xor m_pBox(ROUNDS)
  
  j = ROUNDS - 2
  For i = 0 To (ROUNDS \ 2 - 1)
    Xl = Xl Xor F(Xr)
    Xr = Xr Xor m_pBox(j + 1)
    Xr = Xr Xor F(Xl)
    Xl = Xl Xor m_pBox(j)
    j = j - 2
  Next

End Sub
Private Static Sub EncryptBlock(Xl As Long, Xr As Long)

  Dim i As Long
  Dim j As Long
  Dim Temp As Long
  
  j = 0
  For i = 0 To (ROUNDS \ 2 - 1)
    Xl = Xl Xor m_pBox(j)
    Xr = Xr Xor F(Xl)
    Xr = Xr Xor m_pBox(j + 1)
    Xl = Xl Xor F(Xr)
    j = j + 2
  Next
  
  Temp = Xr
  Xr = Xl Xor m_pBox(ROUNDS)
  Xl = Temp Xor m_pBox(ROUNDS + 1)

End Sub
Public Sub EncryptByte(ByteArray() As Byte, Optional Key As String)

  Dim Offset As Long
  Dim OrigLen As Long
  Dim LeftWord As Long
  Dim RightWord As Long
  Dim CipherLen As Long
  Dim CipherLeft As Long
  Dim CipherRight As Long
  Dim CurrPercent As Long
  Dim NextPercent As Long
  
  'Set the new key if one was provided
  If (Len(Key) > 0) Then Me.Key = Key
  
  'Get the size of the original array
  OrigLen = UBound(ByteArray) + 1
  
  'First we add 12 bytes (4 bytes for the
  'length and 8 bytes for the seed values
  'for the CBC routine), and the ciphertext
  'must be a multiple of 8 bytes
  CipherLen = OrigLen + 12
  If (CipherLen Mod 8 <> 0) Then
    CipherLen = CipherLen + 8 - (CipherLen Mod 8)
  End If
  ReDim Preserve ByteArray(CipherLen - 1)
  Call CopyMem(ByteArray(12), ByteArray(0), OrigLen)
  
  'Store the length descriptor in bytes [9-12]
  Call CopyMem(ByteArray(8), OrigLen, 4)
  
  'Store a block of random data in bytes [1-8],
  'these work as seed values for the CBC routine
  'and is used to produce different ciphertext
  'even when encrypting the same data with the
  'same key)
  Call Randomize
  Call CopyMem(ByteArray(0), CLng(2147483647 * Rnd), 4)
  Call CopyMem(ByteArray(4), CLng(2147483647 * Rnd), 4)
  
  'Encrypt the data in 64-bit blocks
  For Offset = 0 To (CipherLen - 1) Step 8
    'Get the next block of plaintext
    Call GetWord(LeftWord, ByteArray(), Offset)
    Call GetWord(RightWord, ByteArray(), Offset + 4)
    
    'XOR the plaintext with the previous
    'ciphertext (CBC, Cipher-Block Chaining)
    LeftWord = LeftWord Xor CipherLeft
    RightWord = RightWord Xor CipherRight
    
    'Encrypt the block
    Call EncryptBlock(LeftWord, RightWord)
    
    'Store the block
    Call PutWord(LeftWord, ByteArray(), Offset)
    Call PutWord(RightWord, ByteArray(), Offset + 4)
    
    'Store the cipherblock (for CBC)
    CipherLeft = LeftWord
    CipherRight = RightWord
    
    'Update the progress if neccessary
    If (Offset >= NextPercent) Then
      CurrPercent = Int((Offset / CipherLen) * 100)
      NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1
      RaiseEvent Progress(CurrPercent)
    End If
  Next

  'Make sure we return a 100% progress
  If (CurrPercent <> 100) Then RaiseEvent Progress(100)

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

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 Sub DecryptByte(ByteArray() As Byte, Optional Key As String)

  Dim Offset As Long
  Dim OrigLen As Long
  Dim LeftWord As Long
  Dim RightWord As Long
  Dim CipherLen As Long
  Dim CipherLeft As Long
  Dim CipherRight As Long
  Dim CurrPercent As Long
  Dim NextPercent As Long
  
  'Set the new key if one was provided
  If (Len(Key) > 0) Then Me.Key = Key
  
  'Get the size of the ciphertext
  CipherLen = UBound(ByteArray) + 1
  
  'Decrypt the data in 64-bit blocks
  For Offset = 0 To (CipherLen - 1) Step 8
    'Get the next block of ciphertext
    Call GetWord(LeftWord, ByteArray(), Offset)
    Call GetWord(RightWord, ByteArray(), Offset + 4)
    
    'Decrypt the block
    Call DecryptBlock(LeftWord, RightWord)
    
    'XOR with the previous cipherblock
    LeftWord = LeftWord Xor CipherLeft
    RightWord = RightWord Xor CipherRight
    
    'Store the current ciphertext to use
    'XOR with the next block plaintext
    Call GetWord(CipherLeft, ByteArray(), Offset)
    Call GetWord(CipherRight, ByteArray(), Offset + 4)
    
    'Store the block
    Call PutWord(LeftWord, ByteArray(), Offset)
    Call PutWord(RightWord, ByteArray(), Offset + 4)
    
    'Update the progress if neccessary
    If (Offset >= NextPercent) Then
      CurrPercent = Int((Offset / CipherLen) * 100)
      NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1
      RaiseEvent Progress(CurrPercent)
    End If
  Next
  
  'Get the size of the original array
  Call CopyMem(OrigLen, ByteArray(8), 4)
  
  'Make sure OrigLen is a reasonable value,
  'if we used the wrong key the next couple
  'of statements could be dangerous (GPF)
  If (CipherLen - OrigLen > 19) Or (CipherLen - OrigLen < 12) Then
    Call Err.Raise(vbObjectError, , "Incorrect size descriptor in Blowfish decryption")
  End If
  
  'Resize the bytearray to hold only the plaintext
  'and not the extra information added by the
  'encryption routine
  Call CopyMem(ByteArray(0), ByteArray(12), OrigLen)
  ReDim Preserve ByteArray(OrigLen - 1)

  'Make sure we return a 100% progress
  If (CurrPercent <> 100) Then RaiseEvent Progress(100)

End Sub
Private Static Function F(ByVal x As Long) As Long

  Dim xb(0 To 3) As Byte
  
  Call CopyMem(xb(0), x, 4)
  If (m_RunningCompiled) Then
    F = (((m_sBox(0, xb(0)) + m_sBox(1, xb(1))) Xor m_sBox(2, xb(2))) + m_sBox(3, xb(3)))
  Else
    F = UnsignedAdd((UnsignedAdd(m_sBox(0, xb(0)), m_sBox(1, xb(1))) Xor m_sBox(2, xb(2))), m_sBox(3, xb(3)))
  End If

End Function
Public Property Let Key(New_Value As String)

  Dim i As Long
  Dim j As Long
  Dim K As Long
  Dim dataX As Long
  Dim datal As Long
  Dim datar As Long
  Dim Key() As Byte
  Dim KeyLength As Long

  'Do nothing if the key is buffered
  If (m_KeyValue = New_Value) Then Exit Property
  m_KeyValue = New_Value
  
  'Convert the new key into a bytearray
  KeyLength = Len(New_Value)
  Key() = StrConv(New_Value, vbFromUnicode)
  
  'Create key-dependant p-boxes
  j = 0
  For i = 0 To (ROUNDS + 1)
    dataX = 0
    For K = 0 To 3
      Call CopyMem(ByVal VarPtr(dataX) + 1, dataX, 3)
      dataX = (dataX Or Key(j))
      j = j + 1
      If (j >= KeyLength) Then j = 0
    Next
    m_pBox(i) = m_pBox(i) Xor dataX
  Next
  
  datal = 0
  datar = 0
  For i = 0 To (ROUNDS + 1) Step 2
    Call EncryptBlock(datal, datar)
    m_pBox(i) = datal
    m_pBox(i + 1) = datar
  Next

  'Create key-dependant s-boxes
  For i = 0 To 3
    For j = 0 To 255 Step 2
      Call EncryptBlock(datal, datar)
      m_sBox(i, j) = datal
      m_sBox(i, j + 1) = datar
    Next
  Next

End Property
Private Sub Class_Initialize()

  '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-boxes
  m_pBox(0) = &H243F6A88
  m_pBox(1) = &H85A308D3
  m_pBox(2) = &H13198A2E
  m_pBox(3) = &H3707344
  m_pBox(4) = &HA4093822
  m_pBox(5) = &H299F31D0
  m_pBox(6) = &H82EFA98
  m_pBox(7) = &HEC4E6C89
  m_pBox(8) = &H452821E6
  m_pBox(9) = &H38D01377
  m_pBox(10) = &HBE5466CF
  m_pBox(11) = &H34E90C6C
  m_pBox(12) = &HC0AC29B7
  m_pBox(13) = &HC97C50DD
  m_pBox(14) = &H3F84D5B5
  m_pBox(15) = &HB5470917
  m_pBox(16) = &H9216D5D9
  m_pBox(17) = &H8979FB1B

  'Initialize s-boxes
  m_sBox(0, 0) = &HD1310BA6
  m_sBox(1, 0) = &H98DFB5AC
  m_sBox(2, 0) = &H2FFD72DB
  m_sBox(3, 0) = &HD01ADFB7
  m_sBox(0, 1) = &HB8E1AFED
  m_sBox(1, 1) = &H6A267E96
  m_sBox(2, 1) = &HBA7C9045
  m_sBox(3, 1) = &HF12C7F99
  m_sBox(0, 2) = &H24A19947
  m_sBox(1, 2) = &HB3916CF7
  m_sBox(2, 2) = &H801F2E2
  m_sBox(3, 2) = &H858EFC16
  m_sBox(0, 3) = &H636920D8
  m_sBox(1, 3) = &H71574E69
  m_sBox(2, 3) = &HA458FEA3
  m_sBox(3, 3) = &HF4933D7E
  m_sBox(0, 4) = &HD95748F
  m_sBox(1, 4) = &H728EB658
  m_sBox(2, 4) = &H718BCD58
  m_sBox(3, 4) = &H82154AEE
  m_sBox(0, 5) = &H7B54A41D
  m_sBox(1, 5) = &HC25A59B5
  m_sBox(2, 5) = &H9C30D539
  m_sBox(3, 5) = &H2AF26013
  m_sBox(0, 6) = &HC5D1B023
  m_sBox(1, 6) = &H286085F0
  m_sBox(2, 6) = &HCA417918
  m_sBox(3, 6) = &HB8DB38EF
  m_sBox(0, 7) = &H8E79DCB0
  m_sBox(1, 7) = &H603A180E
  m_sBox(2, 7) = &H6C9E0E8B
  m_sBox(3, 7) = &HB01E8A3E
  m_sBox(0, 8) = &HD71577C1
  m_sBox(1, 8) = &HBD314B27
  m_sBox(2, 8) = &H78AF2FDA
  m_sBox(3, 8) = &H55605C60
  m_sBox(0, 9) = &HE65525F3
  m_sBox(1, 9) = &HAA55AB94
  m_sBox(2, 9) = &H57489862
  m_sBox(3, 9) = &H63E81440
  m_sBox(0, 10) = &H55CA396A
  m_sBox(1, 10) = &H2AAB10B6
  m_sBox(2, 10) = &HB4CC5C34
  m_sBox(3, 10) = &H1141E8CE
  m_sBox(0, 11) = &HA15486AF
  m_sBox(1, 11) = &H7C72E993
  m_sBox(2, 11) = &HB3EE1411
  m_sBox(3, 11) = &H636FBC2A
  m_sBox(0, 12) = &H2BA9C55D
  m_sBox(1, 12) = &H741831F6
  m_sBox(2, 12) = &HCE5C3E16
  m_sBox(3, 12) = &H9B87931E
  m_sBox(0, 13) = &HAFD6BA33
  m_sBox(1, 13) = &H6C24CF5C
  m_sBox(2, 13) = &H7A325381
  m_sBox(3, 13) = &H28958677
  m_sBox(0, 14) = &H3B8F4898
  m_sBox(1, 14) = &H6B4BB9AF
  m_sBox(2, 14) = &HC4BFE81B
  m_sBox(3, 14) = &H66282193
  m_sBox(0, 15) = &H61D809CC
  m_sBox(1, 15) = &HFB21A991
  m_sBox(2, 15) = &H487CAC60
  m_sBox(3, 15) = &H5DEC8032
  m_sBox(0, 16) = &HEF845D5D
  m_sBox(1, 16) = &HE98575B1
  m_sBox(2, 16) = &HDC262302