Secure Hash Algorithm (thuật toán băm an toàn)
MD2: Message Digest 2
MD4: Message Digest 4
MD5: Message Digest 5
DES: Data Encryption Standard (chuẩn mã hóa dữ liệu)
AES: Advanced Encryption Standard (chuẩn mã hóa tiên tiến)
MỞ ĐẦU
Ngày nay, cùng với sự phát triển mạnh mẽ của ngành khoa học công nghệ thông tin, internet đã trở thành một nhu cầu, phương tiện không thể thiếu đối với mọi người, việc truyền tin qua mạng ngày càng lớn. Tuy nhiên, với lượng thông tin được truyền qua mạng nhiều hơn thì nguy cơ dữ liệu bị truy cập trái phép cũng tăng lên vì vậy vấn đề bảo đảm an toàn và bảo mật thông tin cho dữ liệu truyền trên mạng là rất cần thiết.
Để đảm bảo an toàn và bí mật cho một thông điệp truyền đi người ta thường dùng phương pháp truyền thống là mã hóa thông điệp theo một qui tắc nào đó đã được thỏa thuận trước giữa người gửi và người nhận. Tuy nhiên, phương thức này thường gây sự chú ý của đối phương về tầm quan trọng của thông điệp. Thời gian gần đây đã xuất hiện một cách tiếp cận mới để truyền các thông điệp bí mật, đó là giấu các thông tin quan trọng trong những bức ảnh thông thường. Nhìn bề ngoài các bức ảnh có chứa thông tin cũng không có gì khác với các bức ảnh khác nên hạn chế được tầm kiểm soát của đối phương. Mặt khác, dù các bức ảnh đó bị phát hiện ra là có chứa thông tin trong đó thì với các khóa có độ bảo mật cao thì việc tìm được nội dung của thông tin đó cũng rất khó có thể thực hiện được.
Xét theo khía cạnh tổng quát thì giấu thông tin cũng là một hệ mã mật nhằm bảo đảm tính an toàn thông tin, nhưng phương pháp này ưu điểm là ở chỗ giảm được khả năng phát hiện được sự tồn tại của thông tin trong nguồn mang. Không giống như mã hóa thông tin là chống sự truy cập và sửa chữa một cách trái phép thông tin, mục tiêu của giấu thông tin là làm cho thông tin trộn lẫn với các điểm ảnh. Điều này sẽ đánh lừa được sự phát hiện của các tin tặc và do đó làm giảm khả năng bị giải mã.
Kết hợp các kỹ thuật giấu tin với các kỹ thuật mã hóa ta có thể nâng cao độ an toàn cho việc truyền tin.
124 trang |
Chia sẻ: lvcdongnoi | Lượt xem: 2768 | Lượt tải: 2
Bạn đang xem trước 20 trang tài liệu Đồ án Tìm hiểu các kỹ thuật giấu tin trong ảnh, xây dựng ứng dụng tích hợp mật mã vào giấu kín trong ảnh, để xem tài liệu hoàn chỉnh bạn click vào nút DOWNLOAD ở trên
_CRYPT_BUSY Then
Exit Sub ' Get out of here!
End If
Dim lKey As Long ' Encryption Key
Dim lBuffLen As Long ' Length of Buffer
Dim lFileLen As Long ' Length of File to encrypt
Dim lFileNum As Long ' File number
Dim lBlockBytes As Long ' How many blocks?
Dim lLostBytes As Long ' How many bytes remaining?
Dim icounter As Long ' Counter
Dim lBytesProcessed As Long ' Bytes processed
Dim bFileData() As Byte ' Buffer of bytes to encrypt
Dim btempFileData() As Byte ' Temp buffer
Dim lLength As Long ' Length of data bytes read/encrypt/write
Dim lResult As Long ' Length of data bytes read/write
Dim lFileAttrib As Long ' File Attributes
Dim lError As Long ' Error values
m_EncDec_Status = EC_CRYPT_BUSY ' working...
'm_EncDec_FileEnc = False ' Start
On Error GoTo ErrEncrypt
' Check if the file exists
If Trim(Dir$(sSourceFile)) = "" Then
lError = ERROR_FILE_NOT_FOUND
Err.Raise vbObjectError ' Fire error handler
'Err.Raise vbObjectError + 1007, , "File not found"
End If
' Proceed...
' Find out which attributes the source file has
' and store it for further setting
If GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_NORMAL Then
lFileAttrib = FILE_ATTRIBUTE_NORMAL
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_SYSTEM Then
lFileAttrib = FILE_ATTRIBUTE_SYSTEM
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_HIDDEN Then
lFileAttrib = FILE_ATTRIBUTE_SYSTEM
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_READONLY Then
lFileAttrib = FILE_ATTRIBUTE_READONLY
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_TEMPORARY Then
lFileAttrib = FILE_ATTRIBUTE_TEMPORARY
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_DIRECTORY Then
lError = ERROR_IS_DIR
Err.Raise vbObjectError ' Fire error handler
End If
' Now set its attributes to normal, so we can
' work with it
If Not lFileAttrib = FILE_ATTRIBUTE_NORMAL Then
SetFileAttributes sSourceFile, FILE_ATTRIBUTE_NORMAL
End If
' Initialize encryption key
lKey = InitKey
If lKey = 0 Then
lError = ERROR_NO_KEY_DERIVED
Err.Raise vbObjectError ' Fire error handler
End If
' Open the file again now using API functions (real fast)
' Source file for reading and writing
lFileNum = CreateFile(sSourceFile, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If lFileNum = INVALID_HANDLE_VALUE Then
lError = ERROR_NO_FILE_OPEN
Err.Raise vbObjectError ' Fire error handler
End If
' Set the file pointer at ReadFromOffset point
SetFilePointer lFileNum, ReadWriteOffset, 0, FILE_BEGIN
' Get the source file length
lFileLen = GetFileSize(lFileNum, 0) - ReadWriteOffset
' Get everything in one shot an write it in one shot
' Prepare buffer space
ReDim bFileData(1 To (lFileLen * 2))
' Read the file in one shot
ReadFile lFileNum, bFileData(1), lFileLen, lResult, ByVal 0&
If lResult lFileLen Then
lError = ERROR_NO_READ
Err.Raise vbObjectError ' Fire error handler
End If
' Put pointer at ReadWriteOffset to write back the encrypted data without corrupting headers
SetFilePointer lFileNum, ReadWriteOffset, 0, FILE_BEGIN
' Raise event EncryptFileStart
RaiseEvent EncryptionFileStart
If lFileLen <= HP_FILE_RW_BLOCKSIZE Then ' If less than encryption blocksize encrypt in one shot
' Let's encrypt the block
' Prepare variables for encryption)
lLength = lFileLen
lBuffLen = UBound(bFileData)
If Not CBool(CryptEncrypt(lKey, 0, 1, 0, bFileData(1), lLength, lBuffLen)) Then
lError = ERROR_NO_ENCRYPT
Err.Raise vbObjectError ' Fire error handler
End If
' Write the results back to the file
WriteFile lFileNum, bFileData(1), lLength, lResult, ByVal 0&
If lResult lLength Then
lError = ERROR_NO_WRITE
Err.Raise vbObjectError ' Fire error handler
End If
' Raise event
RaiseEvent EncryptionFileStatus(lFileLen, lFileLen)
Else
' Find out how many HP_FILE_BLOCKSIZE blocks are
lBlockBytes = lFileLen \ HP_FILE_RW_BLOCKSIZE
' And lost bytes
lLostBytes = lFileLen Mod HP_FILE_RW_BLOCKSIZE
' Allocate space
' Now loop through the blocks and keep encrypting and writing data back to the file
ReDim btempFileData(1 To (HP_FILE_RW_BLOCKSIZE * 2))
Dim Offset As Currency ' just to be sure
Offset = 1 ' offset to read from file data array
lLength = HP_FILE_RW_BLOCKSIZE
For icounter = 1 To lBlockBytes
' Read from source array to temp
CopyMem btempFileData(1), bFileData(Offset), HP_FILE_RW_BLOCKSIZE
' Prepare buffer
lBuffLen = UBound(btempFileData)
' Encrypt data!
If Not CBool(CryptEncrypt(lKey, 0, 0, 0, btempFileData(1), lLength, lBuffLen)) Then
lError = ERROR_NO_ENCRYPT
Err.Raise vbObjectError ' Fire error handler
End If
' Write to file
WriteFile lFileNum, btempFileData(1), lLength, lResult, ByVal 0&
If lResult lLength Then
lError = ERROR_NO_WRITE
Err.Raise vbObjectError ' Fire error handler
End If
' Update offset
Offset = Offset + HP_FILE_RW_BLOCKSIZE
DoEvents
' Raise event
lBytesProcessed = (lBytesProcessed + HP_FILE_RW_BLOCKSIZE)
RaiseEvent EncryptionFileStatus(lBytesProcessed, lFileLen)
Next
' ' Now get the lost bytes [if any]
If lLostBytes 0 Then
' Get them in one shot
ReDim btempFileData(1 To (lLostBytes * 2))
CopyMem btempFileData(1), bFileData(Offset), lLostBytes
' prepare for encryption
lLength = lLostBytes
lBuffLen = UBound(btempFileData)
'Encrypt data!
If Not CBool(CryptEncrypt(lKey, 0, 1, 0, btempFileData(1), lLength, lBuffLen)) Then
lError = ERROR_NO_ENCRYPT
Err.Raise vbObjectError ' Fire error handler
End If
' Write results to file
WriteFile lFileNum, btempFileData(1), lLength, lResult, ByVal 0&
If lResult lLength Then
lError = ERROR_NO_WRITE
Err.Raise vbObjectError ' Fire error handler
End If
' Raise event
lBytesProcessed = (lBytesProcessed + (lLostBytes))
RaiseEvent EncryptionFileStatus(lBytesProcessed, lFileLen)
End If
End If
' Destroy the key
If (lKey) Then CryptDestroyKey lKey
lKey = 0
'' Close the file again
If (lFileNum) Then CloseHandle lFileNum
' Free up resources
Erase bFileData
Erase btempFileData
' Reset - attributes
If lFileAttrib FILE_ATTRIBUTE_NORMAL Then
SetFileAttributes sSourceFile, lFileAttrib
End If
' Not busy anymore
m_EncDec_Status = EC_CRYPT_READY
' Raise final event
RaiseEvent EncryptionFileComplete
Exit Sub
ErrEncrypt:
m_EncDec_Status = EC_CRYPT_READY ' We fail this time but we are ready for some more
Dim sMsg As String
' Close files if open
If (lFileNum) Then
' Reset - attributes
If lFileAttrib FILE_ATTRIBUTE_NORMAL And lError ERROR_IS_DIR Then
SetFileAttributes sSourceFile, lFileAttrib
End If
CloseHandle lFileNum
End If
If (lKey) Then CryptDestroyKey lKey
' Delete temporary file
Select Case lError
Case ERROR_FILE_NOT_FOUND: sMsg = "File not found"
Case ERROR_TMPPTH_NOT_FOUND: sMsg = "Temp Folder not found"
Case ERROR_NO_TMP_FILE: sMsg = "Error creating temporary file"
Case ERROR_NO_READ: sMsg = "Error reading from File"
Case ERROR_NO_WRITE: sMsg = "Error writing to File"
Case ERROR_NO_FILE_OPEN: sMsg = "Error opening source File"
Case ERROR_NO_TMP_OPEN: sMsg = "Error opening temporary File"
Case ERROR_NO_ENCRYPT: sMsg = "Error encrypting File"
Case ERROR_NO_KEY_DERIVED: sMsg = "Error to derive a key for encryption"
Case ERROR_IS_DIR: sMsg = "EzCryptApi does not encrypt directories"
Case Else: Err.Raise Err.Number, "EzCryptoApi", Err.Description
End Select
Err.Raise vbObjectError + lError, "EzCryptoApi", sMsg
End Sub
' EncryptToDestFile Sub procedure: Mã hóa file nguồn thành file đích
' Đầu vào:
' 1] sSourceFile: Đường dẫn và tên file
' 2] sDestFile: File đích để lưu trữ dữ liệu mã hóa.
' 3] WriteToOffset: Vị trí byte offset mà ta bắt đầu ghi kết quả mã Public Sub EncryptToDestFile(ByVal sSourceFile As String, ByVal sDestFile As String, Optional WriteToOffset As Long = 0)
' Before anything starts to rock' and roll
' check if we are busy doing something
If m_EncDec_Status = EC_CRYPT_BUSY Then
Exit Sub ' Get out of here!
End If
Dim lKey As Long ' Encryption Key
Dim lBuffLen As Long ' Length of Buffer
Dim lFileLen As Long ' Length of File to encrypt
Dim lFileNum As Long ' File number
Dim lDestFileNum As Long ' Destination file number
Dim lBlockBytes As Long ' How many blocks?
Dim lLostBytes As Long ' How many bytes remaining?
Dim icounter As Long ' Counter
Dim lBytesProcessed As Long ' Bytes processed
Dim bFileData() As Byte ' Buffer of bytes to encrypt
Dim lLength As Long ' Length of data bytes read/encrypt/write
Dim lResult As Long ' Length of data bytes read/write
Dim lFileAttrib As Long ' File Attributes
Dim lError As Long ' Error values
m_EncDec_Status = EC_CRYPT_BUSY ' working...
On Error GoTo ErrEncrypt
' Check if the file exists
If Trim(Dir$(sSourceFile)) = "" Then
lError = ERROR_FILE_NOT_FOUND
Err.Raise vbObjectError ' Fire error handler
'Err.Raise vbObjectError + 1007, , "File not found"
End If
' Proceed...
' Find out which attributes the source file has
' and store it for further setting
If GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_NORMAL Then
lFileAttrib = FILE_ATTRIBUTE_NORMAL
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_SYSTEM Then
lFileAttrib = FILE_ATTRIBUTE_SYSTEM
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_HIDDEN Then
lFileAttrib = FILE_ATTRIBUTE_SYSTEM
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_READONLY Then
lFileAttrib = FILE_ATTRIBUTE_READONLY
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_TEMPORARY Then
lFileAttrib = FILE_ATTRIBUTE_TEMPORARY
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_DIRECTORY Then
lError = ERROR_IS_DIR
Err.Raise vbObjectError ' Fire error handler
End If
' Now set its attributes to normal, so we can
' work with it
If Not lFileAttrib = FILE_ATTRIBUTE_NORMAL Then
SetFileAttributes sSourceFile, FILE_ATTRIBUTE_NORMAL
End If
' Initialize encryption key
lKey = InitKey
If lKey = 0 Then
lError = ERROR_NO_KEY_DERIVED
Err.Raise vbObjectError ' Fire error handler
End If
' Open the file again now using API functions (real fast)
' Source file for reading and writing
lFileNum = CreateFile(sSourceFile, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If lFileNum = INVALID_HANDLE_VALUE Then
lError = ERROR_NO_FILE_OPEN
Err.Raise vbObjectError ' Fire error handler
End If
' Get the source file length
lFileLen = GetFileSize(lFileNum, 0)
' Now open destination file
lDestFileNum = CreateFile(sDestFile, GENERIC_WRITE, 0, ByVal 0&, OPEN_ALWAYS, ByVal 0&, 0)
If lDestFileNum = INVALID_HANDLE_VALUE Then
lError = ERROR_NO_FILE_OPEN
Err.Raise vbObjectError ' Fire error handler
End If
' Set the source file pointer at the beginning of the file
SetFilePointer lFileNum, 0, 0, FILE_BEGIN
' Put pointer at the beginning of the file to write back the encrypted data
SetFilePointer lDestFileNum, WriteToOffset, 0, FILE_BEGIN
RaiseEvent EncryptionFileStart
If lFileLen <= HP_FILE_RW_BLOCKSIZE Then ' If less than encryption blocksize encrypt in one shot
' Raise event EncryptFileStart
RaiseEvent EncryptionFileStart
' Get everything in one shot an write it in one shot
' Prepare buffer space
ReDim bFileData(1 To (lFileLen * 2))
' Read the file in one shot
ReadFile lFileNum, bFileData(1), lFileLen, lResult, ByVal 0&
If lResult lFileLen Then
lError = ERROR_NO_READ
Err.Raise vbObjectError ' Fire error handler
End If
RaiseEvent EncryptionFileStatus((lFileLen * 0.25), lFileLen)
' Let's encrypt the block
' Prepare variables for encryption)
lLength = lFileLen
lBuffLen = UBound(bFileData)
If Not CBool(CryptEncrypt(lKey, 0, 1, 0, bFileData(1), lLength, lBuffLen)) Then
lError = ERROR_NO_ENCRYPT
Err.Raise vbObjectError ' Fire error handler
End If
' Raise event
RaiseEvent EncryptionFileStatus(lFileLen * 0.5, lFileLen)
' Write the results to destination file
WriteFile lDestFileNum, bFileData(1), lLength, lResult, ByVal 0&
If lResult lLength Then
lError = ERROR_NO_WRITE
Err.Raise vbObjectError ' Fire error handler
End If
' Raise event
RaiseEvent EncryptionFileStatus(lFileLen, lFileLen)
Else
' Find out how many HP_FILE_BLOCKSIZE blocks are
lBlockBytes = lFileLen \ HP_FILE_RW_BLOCKSIZE
' And lost bytes
lLostBytes = lFileLen Mod HP_FILE_RW_BLOCKSIZE
' Allocate space
' Now loop through the blocks and keep encrypting and writing data back to the file
ReDim bFileData(1 To (HP_FILE_RW_BLOCKSIZE * 2))
lLength = HP_FILE_RW_BLOCKSIZE
For icounter = 1 To lBlockBytes
' Read from source
ReadFile lFileNum, bFileData(1), HP_FILE_RW_BLOCKSIZE, lResult, ByVal 0&
If lResult HP_FILE_RW_BLOCKSIZE Then
lError = ERROR_NO_READ
Err.Raise vbObjectError ' Fire error handler
End If
' Prepare buffer
lBuffLen = UBound(bFileData)
' Encrypt data!
If Not CBool(CryptEncrypt(lKey, 0, 0, 0, bFileData(1), lLength, lBuffLen)) Then
lError = ERROR_NO_ENCRYPT
Err.Raise vbObjectError ' Fire error handler
End If
' Write to destination file
WriteFile lDestFileNum, bFileData(1), lLength, lResult, ByVal 0&
If lResult lLength Then
lError = ERROR_NO_WRITE
Err.Raise vbObjectError ' Fire error handler
End If
DoEvents
' Raise event
lBytesProcessed = (lBytesProcessed + HP_FILE_RW_BLOCKSIZE)
RaiseEvent EncryptionFileStatus(lBytesProcessed, lFileLen)
Next
' Now get the lost bytes [if any]
If lLostBytes 0 Then
' Get them in one shot
ReDim bFileData(1 To (lLostBytes * 2))
ReadFile lFileNum, bFileData(1), lLostBytes, lResult, ByVal 0&
If lResult lLostBytes Then
lError = ERROR_NO_READ
Err.Raise vbObjectError ' Fire error handler
End If
' prepare for encryption
lLength = lLostBytes
lBuffLen = UBound(bFileData)
'Encrypt data!
If Not CBool(CryptEncrypt(lKey, 0, 1, 0, bFileData(1), lLength, lBuffLen)) Then
lError = ERROR_NO_ENCRYPT
Err.Raise vbObjectError ' Fire error handler
End If
' Write to results to destination file
WriteFile lDestFileNum, bFileData(1), lLength, lResult, ByVal 0&
If lResult lLength Then
lError = ERROR_NO_WRITE
Err.Raise vbObjectError ' Fire error handler
End If
' Raise event
lBytesProcessed = (lBytesProcessed + (lLostBytes))
RaiseEvent EncryptionFileStatus(lBytesProcessed, lFileLen)
End If
End If
' Destroy the key
If (lKey) Then CryptDestroyKey lKey
lKey = 0
'' Close the file again
If (lFileNum) Then CloseHandle lFileNum
'' Close Destination file
If (lDestFileNum) Then CloseHandle lDestFileNum
' Free up resources
Erase bFileData
'Erase btemFileData
' Set source file attributes back to original
If Not lFileAttrib = FILE_ATTRIBUTE_NORMAL Then
SetFileAttributes sSourceFile, FILE_ATTRIBUTE_NORMAL
End If
' Reset - attributes as the original
SetFileAttributes sDestFile, lFileAttrib
' Not busy anymore
m_EncDec_Status = EC_CRYPT_READY
' Raise final event
RaiseEvent EncryptionFileComplete
Exit Sub
ErrEncrypt:
m_EncDec_Status = EC_CRYPT_READY ' We fail this time but we are ready for some more
Dim sMsg As String
' Close files if open
If (lFileNum) Then
' Reset - attributes
If lFileAttrib FILE_ATTRIBUTE_NORMAL And lError ERROR_IS_DIR Then
SetFileAttributes sSourceFile, lFileAttrib
End If
CloseHandle lFileNum
End If
If (lDestFileNum) Then CloseHandle lDestFileNum
' Destroy key if any
If (lKey) Then CryptDestroyKey lKey
' Delete temporary file
Select Case lError
Case ERROR_FILE_NOT_FOUND: sMsg = "File not found"
Case ERROR_TMPPTH_NOT_FOUND: sMsg = "Temp Folder not found"
Case ERROR_NO_TMP_FILE: sMsg = "Error creating temporary file"
Case ERROR_NO_READ: sMsg = "Error reading from File"
Case ERROR_NO_WRITE: sMsg = "Error writing to File"
Case ERROR_NO_FILE_OPEN: sMsg = "Error opening source File"
Case ERROR_NO_TMP_OPEN: sMsg = "Error opening temporary File"
Case ERROR_NO_ENCRYPT: sMsg = "Error encrypting File"
Case ERROR_NO_KEY_DERIVED: sMsg = "Error to derive a key for encryption"
Case ERROR_IS_DIR: sMsg = "EzCryptApi does not encrypt directories"
Case Else: Err.Raise Err.Number, "EzCryptoApi", Err.Description
End Select
Err.Raise vbObjectError + lError, "EzCryptoApi", sMsg
End Sub
' DecryptFile Sub procedure
' Giải mã file đích thành file nguồn
' Đầu vào:
' 1] sSourceFile: Đường dẫn, tên file đã mã hóa
' 2] ReadWriteOffset: Vị trí byte offset ta bắt đầu đọc dữ liệu để giải
' mã
Public Sub DecryptFile(ByVal sSourceFile As String, Optional ReadWriteOffset As Long = 0)
If m_EncDec_Status = EC_CRYPT_BUSY Then
Exit Sub ' Get out of here!
End If
Dim sTempPath As String ' Path of Temp folder in the system
Dim sTempFilename As String ' Temp filename
Dim lFileTempNum As Long ' Temp file number
Dim lTempPathLen As Long ' Length of Temp path returned by GetTempPath
Dim lKey As Long ' Encryption Key
Dim lFileLen As Long ' Length of File to decrypt
Dim lFileNum As Long ' File number
Dim lBlockBytes As Long ' How many 160 blocks?
Dim lLostBytes As Long ' How many bytes remaining?
Dim icounter As Long ' Counter
Dim jCounter As Long ' Counter
Dim lBytesProcessed As Long ' Bytes processed
Dim bBufflen As Byte ' Length of the buffer to decrypt
Dim bFileData() As Byte ' Holds File Data
Dim btempFileData() As Byte ' Holds Data to write to file [if exceeds block set]
Dim lResult As Long ' Returned values
Dim lLength As Long ' Length of buffer
Dim lFileAttrib As Long ' File attributes
Dim lError As Long ' Error values
On Error GoTo ErrDecryptFile
' We are busy
m_EncDec_Status = EC_CRYPT_BUSY
' Check if the file exists
If Trim(Dir$(sSourceFile)) = "" Then
lError = ERROR_FILE_NOT_FOUND
Err.Raise vbObjectError ' Fire error handler
End If
' Proceed with decryption
' Initialize key
lKey = InitKey
If lKey = 0 Then
lError = ERROR_NO_KEY_DERIVED
Err.Raise vbObjectError ' Fire error handler
End If
' Find out which attributes the source file have
If GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_NORMAL Then
lFileAttrib = FILE_ATTRIBUTE_NORMAL
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_SYSTEM Then
lFileAttrib = FILE_ATTRIBUTE_SYSTEM
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_HIDDEN Then
lFileAttrib = FILE_ATTRIBUTE_SYSTEM
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_READONLY Then
lFileAttrib = FILE_ATTRIBUTE_READONLY
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_TEMPORARY Then
lFileAttrib = FILE_ATTRIBUTE_TEMPORARY
ElseIf GetFileAttributes(sSourceFile) And FILE_ATTRIBUTE_DIRECTORY Then
lError = ERROR_IS_DIR
Err.Raise vbObjectError ' Fire error handler
End If
' Set attributes to normal so we can work with it without problems
If lFileAttrib FILE_ATTRIBUTE_NORMAL Then
SetFileAttributes sSourceFile, FILE_ATTRIBUTE_NORMAL
End If
' Now store the tempfilename into destination file
' Open the file again now using API functions (real fast)
' Source file for reading
lFileNum = CreateFile(sSourceFile, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If lFileNum = INVALID_HANDLE_VALUE Then
lError = ERROR_NO_FILE_OPEN
Err.Raise vbObjectError ' Fire error handler
End If
' Set the file pointer at offset of the file
SetFilePointer lFileNum, ReadWriteOffset, 0, FILE_BEGIN
' Get the source file length
lFileLen = GetFileSize(lFileNum, 0) - ReadWriteOffset
' Get everything in one shot an write it in one shot
ReDim bFileData(1 To lFileLen)
' Read the whole lot in memory!
ReadFile lFileNum, bFileData(1), UBound(bFileData), lResult, ByVal 0&
If lResult UBound(bFileData) Then
lError = ERROR_NO_READ
Err.Raise vbObjectError ' Fire error handler
End If
' Now we close the handle and open the file again
' clearing existing data
CloseHandle lFileNum
' Re-open again
lFileNum = CreateFile(sSourceFile, GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, TRUNCATE_EXISTING, 0, 0)
If lFileNum = INVALID_HANDLE_VALUE Then
lError = ERROR_NO_FILE_OPEN
Err.Raise vbObjectError ' Fire error handler
End If
' Set file pointer to the beginning of the file now as we don't need any headers
SetFilePointer lFileNum, 0, 0, FILE_BEGIN
' Raise event
RaiseEvent DecryptionFileStart
If lFileLen <= HP_FILE_RW_BLOCKSIZE Then
' Let's encrypt the block
' Prepare buffer for encryption
lLength = UBound(bFileData)
'Decrypt data! [Full file Size]
If Not CBool(CryptDecrypt(lKey, 0, 1, 0, bFileData(1), lLength)) Then
lError = ERROR_NO_DECRYPT
Err.Raise vbObjectError ' Fire error handler
End If
' Write the results to back to the file
WriteFile lFileNum, bFileData(1), lLength, lResult, ByVal 0&
If lResult lLength Then
lError = ERROR_NO_WRITE
Err.Raise vbObjectError ' Fire error handler
End If
' Raise event
lBytesProcessed = (lBytesProcessed + lLength)
RaiseEvent DecryptionFileStatus(lBytesProcessed, lFileLen)
Else
' Find out how many HP_FILE_BLOCKSIZE blocks are
lBlockBytes = lFileLen \ HP_FILE_RW_BLOCKSIZE
' And lost bytes
lLostBytes = lFileLen Mod HP_FILE_RW_BLOCKSIZE
' Blocks encrypted
' Now loop through the blocks and keep decrypting
ReDim btempFileData(1 To HP_FILE_RW_BLOCKSIZE)
Dim Offset As Currency ' just to be sure of the file size :o)
Offset = 1 ' offset to read from file data array
lLength = HP_FILE_RW_BLOCKSIZE
For icounter = 1 To lBlockBytes
' Get the block
CopyMem btempFileData(1), bFileData(Offset), HP_FILE_RW_BLOCKSIZE
'Decrypt data!
If Not CBool(CryptDecrypt(lKey, 0, 0, 0, btempFileData(1), lLength)) Then
lError = ERROR_NO_DECRYPT
Err.Raise vbObjectError ' Fire error handler
End If
' Write to temp file
WriteFile lFileNum, btempFileData(1), lLength, lResult, ByVal 0&
If lResult lLength Then
lError = ERROR_NO_WRITE
Err.Raise vbObjectError ' Fire error handler
End If
' Update offset
Offset = Offset + HP_FILE_RW_BLOCKSIZE
' Raise event
lBytesProcessed = (lBytesProcessed + HP_FILE_RW_BLOCKSIZE)
RaiseEvent DecryptionFileStatus(lBytesProcessed, lFileLen)
DoEvents
Next
' Now get the lost bytes [if any]
If lLostBytes 0 Then
' Get them in one shot
ReDim btempFileData(1 To lLostBytes)
CopyMem btempFileData(1), bFileData(Offset), lLostBytes
lLength = lLostBytes
'Decrypt data!
If Not CBool(CryptDecrypt(lKey, 0, 1, 0, btempFileData(1), lLength)) Then
lError = ERROR_NO_DECRYPT
Err.Raise vbObjectError ' Fire error handler
End If
WriteFile lFileNum, btempFileData(1), lLostBytes, lResult, ByVal 0&
If lResult lLostBytes Then
lError = ERROR_NO_WRITE
Err.Raise vbObjectError ' Fire error handler
End If
lBytesProcessed = (lBytesProcessed + lLostBytes)
RaiseEvent DecryptionFileStatus(lBytesProcessed, lFileLen)
End If
End If
If (lKey) Then CryptDestroyKey lKey
CloseHandle lFileNum
lFileNum = 0
' Release resources
If (lKey) Then CryptDestroyKey lKey
' Close files
If (lFileNum) Then CloseHandle lFileNum
Erase bFileData
Erase btempFileData
' Re-set file attributes back to original
If lFileAttrib FILE_ATTRIBUTE_NORMAL Then
SetFileAttributes sSourceFile, lFileAttrib
End If
m_EncDec_Status = EC_CRYPT_READY ' Ready to work again
' Raise final event
RaiseEvent DecryptionFileComplete
Exit Sub
ErrDecryptFile:
m_EncDec_Status = EC_CRYPT_NONE
Dim sMsg As String
If (lKey) Then CryptDestroyKey lKey
If (lFileNum) Then
' Reset - attributes
If lFileAttrib FILE_ATTRIBUTE_NORMAL And lError ERROR_IS_DIR Then
SetFileAttributes sSourceFile, lFileAttrib
End If
CloseHandle lFileNum
End If
Select Case lError
Case ERROR_FILE_NOT_FOUND: sMsg = "File not found"
Case ERROR_TMPPTH_NOT_FOUND: sMsg = "Temp Folder not found"
Case ERROR_NO_TMP_FILE: sMsg = "Error creating temporary file"
Case ERROR_NO_READ: sMsg = "Error reading from File"
Case ERROR_NO_WRITE: sMsg = "Error writing to File"
Case ERROR_NO_FILE_OPEN: sMsg = "Error opening source File"
Case ERROR_NO_TMP_OPEN: sMsg = "Error opening temporary File"
Case ERROR_NO_DECRYPT: sMsg = "Error decrypting File"
Case ERROR_NO_KEY_DERIVED: sMsg = "Error to derive a key for decryption"
Case ERROR_IS_DIR: sMsg = "EzCryptApi does not decrypt directories"
Case Else: Err.Raise Err.Number, "EzCryptoApi", Err.Description
End Select
Err.Raise vbObjectError + lError, "EzCryptoApi", sMsg
End Sub
' InitKey Sub procedure
' Khởi tạo kóa cho mã hóa và giải mã'
' Đầu ra: sẽ điều khiển việc mã hóa hay giải mã dữ liệu:
Private Function InitKey() As Long
Dim lHash As Long
Dim lKey As Long
' Not very optimistic
InitKey = 0
lKey = 0
' No success getting a handle to the provider?
' Then raise an error
If Not CBool(InitProvider()) Then
GoTo Done
'Err.Raise vbObjectError + 1003, , "Error getting a handle to key containers"
End If
If Not CBool(CryptCreateHash(m_CSP_Provider, m_Hash_Algorithm, 0, 0, lHash)) Then
GoTo Done
' Err.Raise vbObject + 1002, , "Unable to initalize hash object for encryption"
End If
'Hash in the password data.
If Not CBool(CryptHashData(lHash, m_EncDec_Password, Len(m_EncDec_Password), 0)) Then
GoTo Done
' Err.Raise vbObjectError + 1010, , "Unable to 'hash' the password"
End If
'Let's derive a session key from the hash object.
If Not CBool(CryptDeriveKey(m_CSP_Provider, m_EncDec_Algorithm, lHash, 0, lKey)) Then
GoTo Done
' Err.Raise vbObjectError + 1011, , "Unable to derive a session key from Hash object"
End If
CryptDestroyHash (lHash)
lHash = 0
' Success? lKey will have a handle to the session key
Done:
InitKey = lKey
End Function
' EncryptData Sub procedure
' Mã hóa một lượng nhỏ của dữ liệu:
' Đầu vào:
' 1] sData: Dữ liệu đem mã hóa
' Đầu ra: dữ liệu mã hóa dạng chuỗi
Public Function EncryptData(ByVal sData As String) As String
' If working get out of here
If m_EncDec_Status = EC_CRYPT_BUSY Then Exit Function
Dim lKey As Long ' Handle to the key
Dim sBuffer As String ' Encrypted buffer
Dim lLength As Long ' Length of buffer to encrypt
Dim lBufLen As Long ' Length of buffer pass to the function
Dim lError As Long ' Error values
On Error GoTo ErrEncrypt
m_EncDec_Status = EC_CRYPT_BUSY
'Get handle to a session key
lKey = InitKey
If lKey = 0 Then
lError = ERROR_NO_KEY_DERIVED
Err.Raise vbObjectError ' Fire error handler
End If
' Raise event
RaiseEvent EncryptionDataStart
'Prepare a string buffer for the CryptEncrypt function
lLength = Len(sData) ' Get the length
lBufLen = lLength * 2 ' Initialize lBufLen with what will be the buffer size
sBuffer = String(lBufLen, vbNullChar) ' Allocate buffer size
LSet sBuffer = sData ' Copy the data to the left of the variable without resizing sBuffer
'Encrypt data!
If Not CBool(CryptStringEncrypt(lKey, 0, 1, 0, sBuffer, lLength, lBufLen)) Then
lError = ERROR_NO_ENCRYPT
Err.Raise vbObjectError ' Fire error handler
End If
' Return encrypted data
EncryptData = Left$(sBuffer, lLength)
'Free up CSP resources
'Destroy session key.
If (lKey) Then CryptDestroyKey lKey
' Raise event
RaiseEvent EncryptionDataComplete
' Ready to work again
m_EncDec_Status = EC_CRYPT_READY
Exit Function
ErrEncrypt:
m_EncDec_Status = EC_CRYPT_NONE
Dim sMsg As String
If (lKey) Then CryptDestroyKey lKey
Select Case lError
Case ERROR_NO_KEY_DERIVED: sMsg = "Error deriving a key for encryption"
Case ERROR_NO_ENCRYPT: sMsg = "Error encrypting data"
Case Else: Err.Raise Err.Number, "EzCryptoApi", Err.Description
End Select
Err.Raise vbObjectError + lError, "EzCryptoApi", sMsg
End Function
' DecryptData Sub procedure: Giải mã một lượng nhỏ của dữ liệu
' Đầu vào: 1] sData: Dữ liệu đem giải mã
' Đầu ra : Dữ liệu giải mã dạng chuỗi
Public Function DecryptData(ByVal sData As String) As String
If m_EncDec_Status = EC_CRYPT_BUSY Then Exit Function
Dim lError As Long ' To raise errors
Dim lKey As Long ' Key to use encryption algorithm
'Dim lResult As Long ' Is the provider ready?
Dim lBufLen As Long ' Length of data
On Error GoTo ErrDecrypt
m_EncDec_Status = EC_CRYPT_BUSY
RaiseEvent DecryptionDataStart
'Get a handle to session key
lKey = InitKey()
If lKey = 0 Then
lError = ERROR_NO_KEY_DERIVED
Err.Raise vbObjectError ' Fire error handler
End If
'Prepare sBuffer for CryptStringDecrypt
lBufLen = Len(sData)
'Decrypt data
If Not CBool(CryptStringDecrypt(lKey, 0, 1, 0, sData, lBufLen)) Then
lError = ERROR_NO_DECRYPT
Err.Raise vbObjectError ' Fire error handler
End If
'Return decrypted string
DecryptData = Mid$(sData, 1, lBufLen)
'Release CSP Resources
If lKey Then CryptDestroyKey lKey
RaiseEvent DecryptionDataComplete
m_EncDec_Status = EC_CRYPT_READY
Exit Function
ErrDecrypt:
m_EncDec_Status = EC_CRYPT_NONE
Dim sMsg As String
Select Case lError
Case ERROR_NO_KEY_DERIVED: sMsg = "Error to derive a key for decryption"
Case ERROR_NO_DECRYPT: sMsg = "Error decrypting data"
Case Else: Err.Raise Err.Number, "EzCryptoApi", Err.Description
End Select
Err.Raise vbObjectError + lError, "Ezcryptoapi", sMsg
End Function
Private Sub Class_Initialize()
' Thuộc tính mặc định của chương trình
Dim lResult As Long
lResult = InitProvider
If lResult = 1 Then CryptReleaseContext m_CSP_Provider, 0
m_CSP_Provider = 0
'm_Hash_Algo_Id = MD5
'm_Hash_Algorithm = CALG_MD5
'm_EncDec_Algo_Id = RC2
'm_EncDec_Algorithm = CALG_RC2
'm_EncDec_Password = "Ez ActiveX Controls"
'm_Speed = [1KB]
HP_FILE_RW_BLOCKSIZE = HP_FILE_RW_BLOCKSIZE_1k
m_Hash_Status = EC_HASH_NONE
End Sub
Mô đun giấu tin:
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "ClsStegano"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'*************************************
'BMP Header Struct
Private BmpHead As winBMPFileHeader
Private BmpInfo As BITMAPINFOHEADER
Private bmpPalette() As BITMAPPalette
Private DeepColor&
'Private mFile2Encode As TypeFileEncode
'*************************************
'BinaryAttach carried the data for each file added in binary format
'BinaryImg() carried tha data for the main image in binary format
Dim BinaryAttach() As tBits, BinaryImg() As tBits
'bAttachdata carried the data for each file added in byte format
'bImgData() carried tha data for the main image in byte format
Dim bImg2Conv() As Byte, bImgData() As Byte, bAttachData() As Byte
'very hard to figure it out that?
'*************************************
Dim mImageFile$ 'Image Filename
Dim mOutputImageFile$ 'New Image Filename
Dim mFilesAdded& 'Count files added
Dim OutFile& 'Pointer to file
Dim mBytesLimit& 'Bytes limit to be added
Dim mBytesAdded& 'Bytes to attach
Dim mImgSize$ 'Image size(width x height)
Dim mImgRes& 'Image resolution 8,16,24 bit
Dim mEncrypMe As Boolean 'Encryp data
Dim mAreLock As Boolean
Dim mBytesExtra& '4 bytes extra when we use encryp over the files, don't ask me why.. just i'd figure it
Dim colFiles As Collection 'My files's collection
Dim cTAG() As Byte 'the main tag to identify if the file carried any file attached
Dim myEncryp As clsEncryp 'Pointer to Encryp class
Event StatusChanged(prcDone As Long, strStatus As String) 'Raise this event to notify what whe are doing
Event SomeError(strDescription As String) 'Raise this event to notify when some error ocurr
' NewEnum tiene que devolver la interfaz IUnknown del
' enumerador de una colección.
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Set NewEnum = colFiles.[_NewEnum]
End Function
Public Property Get ImageFile() As String
ImageFile = mImageFile
End Property
Public Property Let ImageFile(ByVal vNewValue As String)
Dim tmpFil&
mImageFile = vNewValue
mBytesLimit = (FileLen(mImageFile) \ 8) - 1024 '1024bytes reserved, to prevent corrupt the image
tmpFil = FreeFile
Open mImageFile For Binary As tmpFil
ReadHeadImg_ tmpFil
mImgSize = BmpInfo.biWidth & " x " & BmpInfo.biHeight
mImgRes = BmpInfo.byBitCount
Close tmpFil
End Property
Public Property Get FilesAdded() As Long
FilesAdded = mFilesAdded
End Property
'AddFile
'strFile:the filename will be attach
'strTitle the Shortname fot this file, must be the same name with out the extension and the large path
'Key:the unique identify key for this file
Public Function AddFile(strFile As String, strTitle As String, Key As String) As Boolean
Dim tmpFile As ClsFile
On Local Error GoTo AddErr
Set tmpFile = New ClsFile
'fill data
If FileExist(strFile) Then
With tmpFile
.KeyFile = Key
.Filename = strFile
.FileTitle = strTitle
.LenBytes = FileLen(strFile) 'get len in bytes
.TypeFile = VBA.Right$(strFile, 3) 'get type. (.exe,.txt,.bmp...)
mBytesAdded = mBytesAdded + .LenBytes
If mBytesAdded > mBytesLimit Then 'if the files to attach is too long, can't be carried
mBytesAdded = mBytesAdded - .LenBytes
Err.Raise 9001, "AddFile", "The File can't be add. Too long to be attach!"
End If
End With
End If
colFiles.Add tmpFile, Key
mFilesAdded = mFilesAdded + 1
AddFile = True
Exit Function
AddErr:
RaiseEvent SomeError(Err.Description & " in " & Err.Source)
End Function
Public Function RemoveFile(Key As String) As Boolean
On Local Error GoTo AddErr
Dim tmpFile As ClsFile
Set tmpFile = colFiles(Key) 'remove form the collection the file added
mBytesAdded = mBytesAdded - tmpFile.LenBytes 'rest the bytes added too
Set tmpFile = Nothing 'Free memory
colFiles.Remove Key 'remove item
RemoveFile = True
mFilesAdded = mFilesAdded - 1
Exit Function
AddErr:
RaiseEvent SomeError(Err.Description)
Err.Clear
End Function
Public Function GetFile(Key As String) As ClsFile
Attribute GetFile.VB_UserMemId = 0
On Local Error GoTo GetErr
Set GetFile = colFiles(Key) 'return info about any file added
Exit Function
GetErr:
RaiseEvent SomeError(Err.Description)
Err.Clear
End Function
Private Sub Class_Initialize()
Set colFiles = New Collection
Set myEncryp = New clsEncryp
myEncryp.EncryptionAlgorithm = RC2
myEncryp.HashAlgorithm = MD5
myEncryp.Speed = [1KB]
cTAG() = StrConv("TAG:Int21", vbFromUnicode)
End Sub
Public Function Encodeit() As Boolean
Dim strFile$
Dim It As ClsFile
On Local Error GoTo EncodeErr
If FileExist(mImageFile) Then 'Validate filename exist
Dim tmpPalette As BITMAPPalette ' To calculate len of struct
If mEncrypMe Then EncrypFiles
'Process data Image
Call ReadImg_
'convert image data to binary
Call Convert2BinaryArray_(bImg2Conv(), BinaryImg())
RaiseEvent StatusChanged(0, "Preparing data to be write...")
OutFile = FreeFile 'The Main Buffer file
'in this files we going to put all the data, TAG, and each file added
Open "c:\tmp_C23F41AA.dat" For Binary As #OutFile
Put #OutFile, , cTAG() 'TAG identifer
Put #OutFile, , mFilesAdded 'count files added
Put #OutFile, , mBytesAdded 'count bytes added
Put #OutFile, , CLng(mAreLock) 'was encryp??
RaiseEvent StatusChanged(0, "Please Wait...")
ReadAttach_
Close #OutFile
ConvertAttach_
Join_Img_Files_
Kill "c:\tmp_C23F41AA.dat" 'delete buffer file
RaiseEvent StatusChanged(100, "Encode done!")
Else
RaiseEvent SomeError("File doesn't exist") 'Dumb !!
End If
Exit Function
EncodeErr:
RaiseEvent SomeError(Err.Description)
Err.Clear
Close
End Function
Public Function Decodeit() As Boolean
If Not ReadTag_ Then 'Look for tag
RaiseEvent SomeError("The selected image no contain any data to extract or haven't a Xiao format")
Else
ExtractData_
Decodeit = True 'return successful
End If
End Function
Public Sub Save2Image()
Dim strDone$
If mOutputImageFile "" Then
RaiseEvent StatusChanged(0, "Saving file...")
If Not SaveImg_() Then strDone = "Some error saving to new image" Else strDone = "Files was saved!"
RaiseEvent StatusChanged(100, strDone)
Else
RaiseEvent StatusChanged(0, "Image to save not was found!")
End If
End Sub
Private Function SaveImg_() As Boolean
Dim I&, J&, xFil&, lngCounter&
Dim maxArr&
On Local Error GoTo SaveImgErr
'save to new file in disc our image with the file added
maxArr = UBound(bImg2Conv()) 'get max data image
For J = 0 To UBound(BinaryImg()) 'Len image in binary format, must be equal LenImageInBytes * 8
bImg2Conv(I) = Bin2Asc(BinaryImg(J)) 'Convert the binary data to byte, 11111111 = 255
I = I + 1
If I > maxArr Then
Exit For
End If
If myDoEvents Then RaiseEvent StatusChanged(J * 100 / maxArr, "Saving new image...")
Next J
xFil = FreeFile 'prepare our file to be write
Open mOutputImageFile For Binary As #xFil
Put #xFil, , BmpHead 'write header 1st
Put #xFil, , BmpInfo '2th, write info
'write the image data with the files hiden
For lngCounter = 1 To DeepColor 'if exist..write palette data
Put #1, , bmpPalette(lngCounter)
Next lngCounter
Put #xFil, , bImg2Conv() 'finally write the new data with our hide data
Put #xFil, , bImgData() 'put rest of data
Close #xFil 'end of the magic....=)
SaveImg_ = True
Exit Function
SaveImgErr:
RaiseEvent SomeError(Err.Description)
Err.Clear
End Function
Private Function EncrypFiles()
Dim It As ClsFile
Dim strFile$
For Each It In colFiles 'read the files added in the image
strFile = "C:\" & It.FileTitle & ".enc"
myEncryp.EncryptToDestFile It.Filename, strFile, 23
It.Filename = strFile
'when we encryp, the len file changed, we must update that
mBytesAdded = mBytesAdded - It.LenBytes
It.LenBytes = FileLen(strFile)
mBytesAdded = mBytesAdded + It.LenBytes
Next
mBytesExtra = 4
End Function
Private Sub ReadAttach_()
Dim xFil&, I&, lenBy&
Dim It As ClsFile
Dim vData() As Byte, strOut() As Byte
Dim Str3 As String * 3, Str10 As String * 10
Dim strShort$
On Local Error GoTo ReadAttachErr
xFil = FreeFile
'Read attach file
RaiseEvent StatusChanged(0, "Reading file to attach...")
I = 0
For Each It In colFiles 'read the files added in the image
Open It.Filename For Binary As #xFil ' for each file added, build a new temp file in disc
vData = InputB(LOF(xFil), #xFil)
Str3 = It.TypeFile 'txt, bmp, jpg, gif, png
Str10 = It.FileTitle 'the short name
I = I + 1
If myDoEvents Then RaiseEvent StatusChanged((I * 100 / mFilesAdded), "Reading file to attach..." & Str10)
strOut() = StrConv(Str3, vbFromUnicode)
Put #OutFile, , strOut()
Put #OutFile, , It.LenBytes
strOut() = StrConv(Str10, vbFromUnicode)
Put #OutFile, , strOut()
Put #OutFile, , vData()
Close #xFil
Next
Exit Sub
ReadAttachErr:
RaiseEvent SomeError(Err.Description)
Err.Clear
End Sub
Private Sub ReadHeadImg_(pFile&)
Dim tmpPalette As BITMAPPalette
Dim I&
'teh 1st step is read al header for the bitmap, and skip it, to going directly to the image data
Get #pFile, , BmpHead 'fill head struct
Get #pFile, , BmpInfo 'fill info struct
'calculate deepcolor
DeepColor = ((BmpHead.lngBitmapOffset - 54) / Len(tmpPalette))
If DeepColor > 0 Then ReDim bmpPalette(1 To DeepColor) 'Rezise
For I = 1 To DeepColor
Get #pFile, , bmpPalette(I)
Next I
End Sub
Private Sub ReadImg_()
Dim xFil&, Bytes2Hide&, RestBytes&, lngCounter&
Dim bytColor As Byte
'Read the Img File
xFil = FreeFile
Open mImageFile For Binary As #xFil
RaiseEvent StatusChanged(0, "Reading Header...")
ReadHeadImg_ xFil
'Calculate len image data, without headers
'Only read the len of bytes we going to hide
'calculate the len data must be read
'17= len of main header,TAG:Int21(9bytes)+filesadded(4bytes)+bytesadded(4bytes)
'17=len of file header, type(3bytes)+filelen(4bytes)+filename(10byte)
Bytes2Hide = (mBytesAdded + 17 + (17 * mFilesAdded) + mBytesExtra) * 8 'LOF(ImgFile) - Loc(ImgFile)
ReDim bImg2Conv(0 To Bytes2Hide) 'NEW- 1 bytes to hide is equal to 8 bytes of data
RestBytes = (BmpHead.lngFileSize - BmpHead.lngBitmapOffset) - Bytes2Hide 'New
ReDim bImgData(0 To RestBytes)
RaiseEvent StatusChanged(0, "Reading Image Data...")
For lngCounter = 0 To Bytes2Hide ' this is the data where we going to hide our files
If Not EOF(xFil) Then
Get #xFil, , bytColor 'Read each rgb byte info
bImg2Conv(lngCounter) = bytColor
End If
If myDoEvents Then RaiseEvent StatusChanged(lngCounter * 100 / Bytes2Hide, "Reading Image Data...")
Next lngCounter
For lngCounter = 0 To RestBytes ' this is the rest data
If Not EOF(xFil) Then
Get #xFil, , bytColor 'Read each rgb byte info
bImgData(lngCounter) = bytColor
End If
If myDoEvents Then RaiseEvent StatusChanged(lngCounter * 100 / RestBytes, "Reading Image Data...")
Next lngCounter
Close #xFil
End Sub
'Look for our tag in the image file, if doesn't exist skip all
Private Function ReadTag_() As Boolean
Dim binData() As tBits, binTag() As tBits
Dim I&, J&, Cur&, bytColor As Byte, Ret&
Dim strMyTag As String * 9
Dim lenStruct&, xFil&
Dim bBytes() As Byte
RaiseEvent StatusChanged(0, "Searching header...")
lenStruct = 17 'the len for the tag is always 17 bytes
ReDim binTag(0 To lenStruct)
xFil = FreeFile
Open mImageFile For Binary As #xFil
ReadHeadImg_ xFil 'Read header for bitmap
lenStruct = 168 '8 bytes = 1 extra-byte, TAG= 21 bytes * 8 bytes = 168 bytes
ReDim bImgData(0 To lenStruct)
For I = 0 To lenStruct
If Not EOF(xFil) Then
Get #xFil, , bytColor
bImgData(I) = bytColor
End If
Next I
Close #xFil
Call Convert2BinaryArray_(bImgData(), binData())
lenStruct = UBound(binTag()) 'len data in binary
Cur = 0
lenStruct = 9 'the len tag is alway 9bytes
For I = 0 To lenStruct
For J = 0 To 7
binTag(I).Bits(J) = binData(Cur).Bits(7)
Cur = Cur + 1
Next J
If Cur >= 72 Then Exit For
Next I
strMyTag = Binary2String(binTag)
If strMyTag = "TAG:Int21" Then
ReDim binTag(0 To 4)
ReDim bBytes(0 To 4)
Cur = 72
For I = 0 To 4
For J = 0 To 7
binTag(I).Bits(J) = binData(Cur).Bits(7)
Cur = Cur + 1
Next J
If Cur >= 104 Then Exit For
bBytes(I) = Bin2Asc(binTag(I))
Next I
CopyMemory mFilesAdded, bBytes(0), Len(mFilesAdded)
Cur = 104
For I = 0 To 4
For J = 0 To 7
binTag(I).Bits(J) = binData(Cur).Bits(7)
Cur = Cur + 1
Next J
If Cur >= 136 Then Exit For
bBytes(I) = Bin2Asc(binTag(I))
Next I
CopyMemory mBytesAdded, bBytes(0), Len(mBytesAdded)
Cur = 136
For I = 0 To 4
For J = 0 To 7
binTag(I).Bits(J) = binData(Cur).Bits(7)
Cur = Cur + 1
Next J
If Cur >= 168 Then Exit For
bBytes(I) = Bin2Asc(binTag(I))
Next I
CopyMemory Ret, bBytes(0), Len(Ret)
mAreLock = Ret
If mAreLock Then mBytesExtra = 4
ReadTag_ = True
End If
'ReadTag_ = (strMyTag = "TAG:Int21")
End Function
Private Sub ExtractData_()
Dim OutFile&, ImgFile&
Dim tmpFile&
Dim dataOut() As Byte
Dim BinOut() As tBits
Dim Bytes2Read&, Cur&, I&, J&
Dim bytColor As Byte
Dim sTAg$, lFA&, lBA&, sTF$, lLF&, sNF$
ImgFile& = FreeFile
Open mImageFile$ For Binary As #ImgFile 'open the main image
'skip the bmp header, to get the real image data
Call ReadHeadImg_(ImgFile)
'calculate the len data must be read
'17= len of main header,TAG:Int21(9bytes)+filesadded(4bytes)+bytesadded(4bytes)
'17=len of file header, type(3bytes)+filelen(4bytes)+filename(10byte)
Bytes2Read = (mBytesAdded + 17 + (17 * mFilesAdded) + mBytesExtra) * 8 'LOF(ImgFile) - Loc(ImgFile)
ReDim dataOut(0 To Bytes2Read)
For I = 0 To (Bytes2Read)
If Not EOF(ImgFile) Then
Get #ImgFile, , bytColor
dataOut(I) = bytColor
End If
Next I
Close #ImgFile
Call Convert2BinaryArray_(dataOut(), BinaryImg())
Bytes2Read = UBound(BinaryImg()) 'len image in binary
mBytesAdded = (mBytesAdded + 17 + (17 * mFilesAdded) + mBytesExtra)
ReDim dataOut(0 To mBytesAdded)
ReDim BinOut(0 To Bytes2Read)
Cur = 0
'we going to read the bytes 7 for each byte in the image data
'and put it in other array to extract the hide data
For I = 0 To mBytesAdded
For J = 0 To 7
If Cur >= Bytes2Read Then Exit For
BinOut(I).Bits(J) = BinaryImg(Cur).Bits(7)
Cur = Cur + 1
Next J
dataOut(I) = Bin2Asc(BinOut(I)) 'convert the binary hide in bytes
myDoEvents
Next I
OutFile = FreeFile
Open "c:\tmp_DD2741C.dat" For Binary As #OutFile 'tmp file to read data
Put #OutFile, , dataOut()
Close OutFile
OutFile = FreeFile
mBytesAdded = 0
mFilesAdded = 0
Open "c:\tmp_DD2741C.dat" For Binary As #OutFile 'tmp file to read data
sTAg = ExtractItem_(OutFile, 9, 0, 1) 'Read the main tag
lFA = ExtractItem_(OutFile, 4, 0, 0) 'read the number of files added
lBA = ExtractItem_(OutFile, 4, 0, 0) 'read the len of bytes added
mAreLock = ExtractItem_(OutFile, 4, 0, 0) 'was encryp??
Dim strFile$
Dim It As ClsFile
For I = 1 To lFA
sTF = ExtractItem_(OutFile, 3, 0, 1) 'Read the type file(txt,bmp,gif,jpg,png)
lLF = ExtractItem_(OutFile, 4, 0, 0) 'read the len in bytes for this file
sNF = ExtractItem_(OutFile, 10, 0, 1) 'read the short name for this file
strFile = "c:\" & sNF & "DD2741C." & sTF 'build the buffer filename
tmpFile = FreeFile
Open strFile For Binary As tmpFile
dataOut() = InputB(lLF, OutFile) 'read n-bytes, the len for this file
Put tmpFile, , dataOut() 'write in disc
Close tmpFile
AddFile strFile, sNF, CStr("c0" & I) 'add in the class
'mBytesAdded = mBytesAdded + lLF 'counter the bytes added in the image
Next
Close OutFile
Kill "c:\tmp_DD2741C.dat"
End Sub
Private Function ExtractItem_(pFile As Long, Bytes2Read As Long, Bytes2Look As Long, RetType As Integer)
Dim Memo() As Byte
Dim lLong&
Dim strEnd$
Memo() = InputB(Bytes2Read, pFile) 'read n-bytes from disc
If RetType = 0 Then 'Numeric
CopyMemory lLong, Memo(0), Len(lLong)
ExtractItem_ = lLong
ElseIf RetType = 1 Then 'String
strEnd = Memo()
ExtractItem_ = StrConv(strEnd, vbUnicode)
End If
End Function
Private Sub ConvertAttach_()
Dim byt As Byte
Dim LenF&, I&
On Local Error GoTo ErrConvert
'Read all files added and convert to binary
OutFile = FreeFile
Open "c:\tmp_C23F41AA.dat" For Binary As #OutFile
LenF = LOF(OutFile) - 1
ReDim bAttachData(0 To LenF)
For I = 0 To LenF
If Not EOF(OutFile) Then
Get OutFile, , byt
bAttachData(I) = byt
End If
Next
Close #OutFile
Call Convert2BinaryArray_(bAttachData(), BinaryAttach())
Exit Sub
ErrConvert:
RaiseEvent SomeError(Err.Description)
Err.Clear
End Sub
'the magic function, joing image and files to attach in only one file
Private Sub Join_Img_Files_()
Dim I&, J&, K&, LenImg&, LenF&
LenImg = UBound(BinaryImg()) 'len in binary of image
LenF = UBound(BinaryAttach()) 'len in binary for files to attach
I = 0
For J = 0 To LenF
For K = 0 To 7
BinaryImg(I).Bits(7) = BinaryAttach(J).Bits(K) 'put one bit from binary data to hide in the bit 7
I = I + 1
Next K
If I >= LenImg Then Exit For
If myDoEvents Then RaiseEvent StatusChanged((I * 100 / LenImg), "Joining files with image...")
Next J
End Sub
'Convert2BinaryArray_
'Source(): the file data in bytes
'retArray(): the Binary data to be return
Private Sub Convert2BinaryArray_(Source() As Byte, RetArray() As tBits)
Dim LenArray&, I&
Dim arrBinary() As tBits
Dim Bits8 As tBits
LenArray = UBound(Source())
ReDim arrBinary(0 To LenArray)
For I = 0 To LenArray
Bits8 = ByteToBinary(Source(I)) 'convert 1 byte to binary
arrBinary(I) = Bits8
If myDoEvents Then RaiseEvent StatusChanged((I * 100 / LenArray), "Convert Hex to Binary...")
Next I
RetArray = arrBinary
End Sub
Private Function FileExist(strFile As String) As Boolean
Dim Rs$, Tama As Boolean
Dim tm&
Rs = Dir(strFile)
FileExist = (Len(Rs))
End Function
Public Property Get OutputImageFile() As String
OutputImageFile = mOutputImageFile
End Property
Public Property Let OutputImageFile(ByVal sNewFile As String)
mOutputImageFile = sNewFile
End Property
Private Sub Class_Terminate()
Dim tmpClass As ClsFile
For Each tmpClass In colFiles
Set tmpClass = Nothing
Next
Set colFiles = Nothing
If myEncryp.IsHashReady Then myEncryp.DestroyHash
Set myEncryp = Nothing
'free memory
Erase BinaryAttach()
Erase BinaryImg()
Erase bImgData()
Erase bImg2Conv()
Erase bAttachData()
End Sub
Public Property Get BytesAdded() As Long
BytesAdded = mBytesAdded
End Property
Public Property Get BytesTotal() As Variant
BytesTotal = mBytesLimit
End Property
'Public Property Get File2Encode() As TypeFileEncode
' File2Encode = mFile2Encode
'End Property
'
'Public Property Let File2Encode(ByVal tNewType As TypeFileEncode)
' mFile2Encode = tNewType
'End Property
Public Property Get ImgSize() As String
ImgSize = mImgSize
End Property
Public Property Get ImgRes() As Long
ImgRes = mImgRes
End Property
Public Property Get EncrypMe() As Boolean
EncrypMe = mEncrypMe
End Property
Public Property Let EncrypMe(ByVal bNewEncryp As Boolean)
mEncrypMe = bNewEncryp
mAreLock = mEncrypMe
End Property
Public Property Get EncryptionAlgorithm() As EC_CRYPT_ALGO_ID
EncryptionAlgorithm = myEncryp.EncryptionAlgorithm
End Property
Public Property Let EncryptionAlgorithm(ByVal ecEncryptID As EC_CRYPT_ALGO_ID)
myEncryp.EncryptionAlgorithm = ecEncryptID
End Property
Public Property Get HashAlgorithm() As EC_HASH_ALG_ID
HashAlgorithm = myEncryp.HashAlgorithm
End Property
Public Property Let HashAlgorithm(ByVal hAlgoId As EC_HASH_ALG_ID)
myEncryp.HashAlgorithm = hAlgoId
End Property
Public Property Get Pwd() As String
Pwd = myEncryp.Password
End Property
Public Property Let Pwd(ByVal sPassword As String)
myEncryp.Password = sPassword
End Property
Public Property Get areLock() As Boolean
areLock = mAreLock
End Property
Public Property Let areLock(ByVal bNewLock As Boolean)
mAreLock = bNewLock
End Property
Public Function UnLockMe(strLockFile As String, DestFile As String)
If mAreLock Then myEncryp.DecryptToDestFile strLockFile, DestFile, 23
End Function
Các file đính kèm theo tài liệu này:
- doantotnghiep_8513.doc