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 tin trong ảnh

_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