module2.bas

把文件隐藏到图片中

Attribute VB_Name = "Module2"
Option Explicit
Public result As Integer, i As Integer
Public bufs(11) As Byte, byte_bufs(7) As Byte, msgs(2) As Byte
Public file_len As Long, pic_offset As Long, zlen As Long, flen As Long
Public percentFinish As Double
'*********高密嵌入时要用到的过程***************
'**********************************************

 Sub setMask_R()
Select Case result:
    Case 0:
    bufs(i) = bufs(i) And &HFC
    Case 1:
    bufs(i) = (bufs(i) And &HFD) Or &H1
    Case 2:
    bufs(i) = (bufs(i) And &HFE) Or &H2
    Case 3:
    bufs(i) = bufs(i) Or &H3
End Select
End Sub
 Sub setMask_G()
Select Case result:
    Case 0:
    bufs(i) = bufs(i) And &HFE
    Case 4:
    bufs(i) = bufs(i) Or &H1
End Select
End Sub
 Sub setMask_B()
Select Case result:
    Case 0:
    bufs(i) = (bufs(i) And &HF8)
    Case 8:
    bufs(i) = (bufs(i) And &HF9) Or &H1
    Case 16:
    bufs(i) = (bufs(i) And &HFA) Or &H2
    Case 24:
    bufs(i) = (bufs(i) And &HFB) Or &H3
    Case 32:
    bufs(i) = (bufs(i) And &HFC) Or &H4
    Case 40:
    bufs(i) = (bufs(i) And &HFD) Or &H5
    Case 48:
    bufs(i) = (bufs(i) And &HFE) Or &H6
    Case 56:
    bufs(i) = bufs(i) Or &H7
End Select
End Sub
 Sub setMask_R_msg0_left()
Select Case result:
    Case 0:
    bufs(i) = bufs(i) And &HFC
    Case 64:
    bufs(i) = (bufs(i) And &HFD) Or &H1
    Case 128:
    bufs(i) = (bufs(i) And &HFE) Or &H2
    Case 192:
    bufs(i) = bufs(i) Or &H3
    
End Select
End Sub
 Sub setMask_G_msg1_left()
Select Case result:
    Case 0:
    bufs(i) = bufs(i) And &HFE
    Case 64:
    bufs(i) = bufs(i) Or &H1
End Select
End Sub
 Sub setMask_B_msg1_left()
Select Case result:
    Case 0:
    bufs(i) = bufs(i) And &HFB
    Case 128:
    bufs(i) = bufs(i) Or &H4
End Select
End Sub
 Sub setMask_B_msg2_left()
Select Case result:
    Case 0:
    bufs(i) = bufs(i) And &HFC
    Case 64:
    bufs(i) = (bufs(i) And &HFD) Or &H1
    Case 128:
    bufs(i) = (bufs(i) And &HFE) Or &H2
    Case 192:
    bufs(i) = bufs(i) Or &H3
End Select
End Sub
'***************************************
'***************************************

'****高密取出时要用到的过程*************
'***************************************
Sub outMsg_R()
Select Case result:
    Case 0:
    msgs(i) = msgs(i) And &HFC
    Case 1:
    msgs(i) = (msgs(i) And &HFD) Or &H1
    Case 2:
    msgs(i) = (msgs(i) And &HFE) Or &H2
    Case 3:
    msgs(i) = msgs(i) Or &H3
End Select
End Sub
 Sub outMsg_G()
Select Case result:
    Case 0:
    msgs(i) = msgs(i) And &HFB
    Case 1:
    msgs(i) = msgs(i) Or &H4
End Select
End Sub
 Sub outMsg_B()
Select Case result:
    Case 0:
    msgs(i) = msgs(i) And &HC7
    Case 1:
    msgs(i) = (msgs(i) And &HCF) Or &H8
    Case 2:
    msgs(i) = (msgs(i) And &HD7) Or &H10
    Case 3:
    msgs(i) = (msgs(i) And &HDF) Or &H18
    Case 4:
    msgs(i) = (msgs(i) And &HE7) Or &H20
    Case 5:
    msgs(i) = (msgs(i) And &HEF) Or &H28
    Case 6:
    msgs(i) = (msgs(i) And &HF7) Or &H30
    Case 7:
    msgs(i) = msgs(i) Or &H38
End Select
End Sub
 Sub outMsg0_R_left()
Select Case result:
    Case 0:
    msgs(0) = msgs(0) And &H3F
    Case 1:
    msgs(0) = (msgs(0) And &H7F) Or &H40
    Case 2:
    msgs(0) = (msgs(0) And &HBF) Or &H80
    Case 3:
    msgs(0) = msgs(0) Or &HC0
End Select
End Sub
 Sub outMsg1_G_left()
Select Case result:
    Case 0:
    msgs(1) = msgs(1) And &HBF
    Case 1:
    msgs(1) = msgs(1) Or &H40
End Select
End Sub
 Sub outMsg1_B_left()
Select Case result:
    Case 0:
    msgs(1) = msgs(1) And &H7F
    Case 4:
    msgs(1) = msgs(1) Or &H80
End Select
End Sub
 Sub outMsg2_B_left()
Select Case result:
    Case 0:
    msgs(2) = msgs(2) And &H3F
    Case 1:
    msgs(2) = (msgs(2) And &H7F) Or &H40
    Case 2:
    msgs(2) = (msgs(2) And &HBF) Or &H80
    Case 3:
    msgs(2) = msgs(2) Or &HC0
End Select
End Sub
'****************************************
'****************************************


'*********高密嵌入算法*****************
'**************************************
Sub compressHigh()
On Error GoTo ErrorHandle
Dim filepointer As Long
file_len = 0: pic_offset = 0: zlen = 0
'打开BMP图片与信息文件
Open bmpFileName For Binary As #1
Open inMsgName For Binary As #2
'取得信息文件长度
file_len = LOF(2)
'从bmp中读取位图开始处
Get 1, 11, pic_offset
pic_offset = pic_offset + 1
If ((LOF(1) - pic_offset) - 12 \ 4) < (file_len + 3) Then
Close #1
Close #2
MsgBox "信息太大，不可以嵌入！", vbCritical, "注意"
Exit Sub
End If
'向从BMP图片中写入信息长度,有无使用密码
If FrmMain.ChkPassword Then
file_len = (file_len And &HFFFFFF) Or &H18000000
Else
file_len = (file_len And &HFFFFFF) Or &H10000000
End If
Put 1, 7, file_len
file_len = file_len And &HFFFFFF

'保存位图开始处读写指针，写入信息时会用
Get 1, pic_offset - 8, byte_bufs
'filepointer = Loc(1)
'前16个字节用于保存扩展名，密码长度，密码
Put 1, , extName
Put 1, , passwordLen
Put 1, , password
filepointer = Loc(1)

'跳到位图开始处，开始读入位图数据
'********************************************
FrmMain.Labtmp.Caption = "                        完成度"
'以下循环过程将信息写入BMP
flen = file_len \ 3
For zlen = 1 To flen
    DoEvents
    Get 1, , bufs
    Get 2, , msgs
   
    '取出msg 0 第底1.2位
    result = msgs(0) And &H3
    i = 0
    Call setMask_R
    '取出msg 0 第底3位
    result = msgs(0) And &H4
    i = 1
    Call setMask_G
    '取出msg 0 第底4.5.6位
    result = msgs(0) And &H38
    i = 2
    Call setMask_B
    '取出msg 1 第底1.2位
    result = msgs(1) And &H3
    i = 3
    Call setMask_R
    '取出msg 1 第底3位
    result = msgs(1) And &H4
    i = 4
    Call setMask_G
    '取出msg 1 第底4.5.6位
    result = msgs(1) And &H38
    i = 5
    Call setMask_B
    '取出msg 2 第底1.2位
    result = msgs(2) And &H3
    i = 6
    Call setMask_R
    '取出msg 2 第底3位
    result = msgs(2) And &H4
    i = 7
    Call setMask_G
    '取出msg 2 第底4.5.6位
    result = msgs(2) And &H38
    i = 8
    Call setMask_B
    '取出msg 0 第底7.8位
    result = msgs(0) And &HC0
    i = 9
    Call setMask_R_msg0_left
    '取出msg 1 第底7位
    result = msgs(1) And &H40
    i = 10
    Call setMask_G_msg1_left
    '取出msg 1 第底8位
    result = msgs(1) And &H80
    i = 11
    Call setMask_B_msg1_left
    '取出msg 2 第底7.8位
    result = msgs(2) And &HC0
    i = 11
    Call setMask_B_msg2_left
      
Put 1, filepointer + 1, bufs
filepointer = Loc(1)
percentFinish = Int((zlen / flen) * 100)
FrmMain.labfinish.Caption = percentFinish & "%"
Next zlen
Select Case (file_len Mod 3)
Case 1:
    Get 1, , bufs
    Get 2, , msgs
   
    '取出msg 0 第底1.2位
    result = msgs(0) And &H3
    i = 0
    Call setMask_R
    '取出msg 0 第底3位
    result = msgs(0) And &H4
    i = 1
    Call setMask_G
    '取出msg 0 第底4.5.6位
    result = msgs(0) And &H38
    i = 2
    Call setMask_B
     '取出msg 0 第底7.8位
    result = msgs(0) And &HC0
    i = 9
    Call setMask_R_msg0_left
      
    Put 1, filepointer + 1, bufs

Case 2:
  Get 1, , bufs
    Get 2, , msgs
   
    '取出msg 0 第底1.2位
    result = msgs(0) And &H3
    i = 0
    Call setMask_R
    '取出msg 0 第底3位
    result = msgs(0) And &H4
    i = 1
    Call setMask_G
    '取出msg 0 第底4.5.6位
    result = msgs(0) And &H38
    i = 2
    Call setMask_B
    '取出msg 1 第底1.2位
    result = msgs(1) And &H3
    i = 3
    Call setMask_R
    '取出msg 1 第底3位
    result = msgs(1) And &H4
    i = 4
    Call setMask_G
    '取出msg 1 第底4.5.6位
    result = msgs(1) And &H38
    i = 5
    Call setMask_B
    '取出msg 0 第底7.8位
    result = msgs(0) And &HC0
    i = 9
    Call setMask_R_msg0_left
    '取出msg 1 第底7位
    result = msgs(1) And &H40
    i = 10
    Call setMask_G_msg1_left
    '取出msg 1 第底8位
    result = msgs(1) And &H80
    i = 11
    Call setMask_B_msg1_left
     
    Put 1, filepointer + 1, bufs
End Select
Close #1
Close #2
FrmMain.Labtmp.Caption = "嵌入完成！"
MsgBox "嵌入完成！", vbInformation, "消息"
'********************************************

'更改界面
haveMsg = 1
'结束
Exit Sub
ErrorHandle:
MsgBox "发生了异常错误，可能是 BMP文件为只读属性，请检查！若无法解决问题，请与作者联系！", vbCritical
Close
End Sub
'********************************
'********************************

'******高密脱壳算法**************
'********************************
Sub unzip_High()
On Error GoTo ErrorHandle
    '从bmp中读取位图开始处
    Get 1, 11, pic_offset
    '跳到位图开始处
    '下面的GET语句读入的信息无用，但语句必须保留
    Get 1, pic_offset + 12 - 7, byte_bufs
    FrmMain.Labtmp.Caption = "                        完成度"
    Dim filepointer As Long
    filepointer = Loc(1)
    flen = file_len \ 3
For zlen = 1 To flen
    DoEvents
    Get 1, , bufs
    '组合msg 0第1.2位
    i = 0
    result = bufs(0) And &H3
    Call outMsg_R
    '组合msg 0第3位
    result = bufs(1) And &H1
    Call outMsg_G
    '组合msg 0第4.5.6位
    result = bufs(2) And &H7
    Call outMsg_B
    '组合msg 0第7.8位
    result = bufs(9) And &H3
    Call outMsg0_R_left
    '组合msg 1第1.2位
    i = 1
    result = bufs(3) And &H3
    Call outMsg_R
    '组合msg 1第3位
    result = bufs(4) And &H1
    Call outMsg_G
    '组合msg 1第4.5.6位
    result = bufs(5) And &H7
    Call outMsg_B
    '组合msg 1第7位
    result = bufs(10) And &H1
    Call outMsg1_G_left
    '组合msg 1第8位
    result = bufs(11) And &H4
    Call outMsg1_B_left
    '组合msg 2第1.2位
    i = 2
    result = bufs(6) And &H3
    Call outMsg_R
    '组合msg 2第3位
    result = bufs(7) And &H1
    Call outMsg_G
    '组合msg 2第4.5.6位
    result = bufs(8) And &H7
    Call outMsg_B
    '组合msg 2第7.8位
    result = bufs(11) And &H3
    Call outMsg2_B_left
   
    Put 2, , msgs
    percentFinish = Int((zlen / flen) * 100)
    FrmMain.labfinish = percentFinish & "%"
Next zlen
Select Case (file_len Mod 3)
Case 1:
 Get 1, , bufs
    '组合msg 0第1.2位
    i = 0
    result = bufs(0) And &H3
    Call outMsg_R
    '组合msg 0第3位
    result = bufs(1) And &H1
    Call outMsg_G
    '组合msg 0第4.5.6位
    result = bufs(2) And &H7
    Call outMsg_B
    '组合msg 0第7.8位
    result = bufs(9) And &H3
    Call outMsg0_R_left
   Put 2, , msgs(0)
Case 2:
 Get 1, , bufs
    '组合msg 0第1.2位
    i = 0
    result = bufs(0) And &H3
    Call outMsg_R
    '组合msg 0第3位
    result = bufs(1) And &H1
    Call outMsg_G
    '组合msg 0第4.5.6位
    result = bufs(2) And &H7
    Call outMsg_B
    '组合msg 0第7.8位
    result = bufs(9) And &H3
    Call outMsg0_R_left
    '组合msg 1第1.2位
    i = 1
    result = bufs(3) And &H3
    Call outMsg_R
    '组合msg 1第3位
    result = bufs(4) And &H1
    Call outMsg_G
    '组合msg 1第4.5.6位
    result = bufs(5) And &H7
    Call outMsg_B
    '组合msg 1第7位
    result = bufs(10) And &H1
    Call outMsg1_G_left
    '组合msg 1第8位
    result = bufs(11) And &H4
    Call outMsg1_B_left
   
    Put 2, , msgs(0)
    Put 2, , msgs(1)
End Select
Exit Sub
ErrorHandle:
MsgBox "发生了异常错误，也许是输出文件的相关属性设置不正确，比如为只读属性，请确认，若无法解决问题，请与作者联系！", vbCritical

End Sub