si.frm

把文件隐藏到图片中

havepassword = 24
Else
    Text1.Enabled = False
    Text2.Enabled = False
    havepassword = 0
End If
End Sub

Private Sub CmdAbout_Click()
FrmAbout.Show (1)
FrmAbout.Timer1.Enabled = True
End Sub

Private Sub Cmdexit_Click()
'关闭所有打开的文件
Close
SaveSetting appname:="ZXApp", section:="ShadowInk", _
            Key:="clearBMP", setting:=ChkclearBmp.Value
isExit = True
Timer1.Enabled = False
'特效
Dim GotoVal As Long
GotoVal = Me.Height / 2

Dim Gointo As Long
For Gointo = 1 To GotoVal
    'NEW ADDITION NEXT LINE


    DoEvents
        Me.Height = Me.Height - 10
        'Me.Top = (Screen.Height - Me.Height) \ 2
        If Me.Height <= 11 Then GoTo horiz
    Next Gointo


    'This is the width part of the same sequence above
horiz:
    Me.Height = 30
    GotoVal = Me.Width / 2


    For Gointo = 1 To GotoVal
        'NEW ADDITION NEXT LINE


        DoEvents
            Me.Width = Me.Width - 10
            'Me.Left = (Screen.Width - Me.Width) \ 2
            If Me.Width <= 11 Then End
        Next Gointo
        
End
End Sub

Private Sub CmdMsgSelect_Click()
If bmpFileName = "" Then
    MsgBox "请先选择图片！", vbInformation, "注意"
    Exit Sub
End If
If haveMsg Then
    MsgBox "图片里有信息，不可选择文件", vbCritical, "错误"
    Exit Sub
End If
'选择要嵌入的文件
Dim preMsgfile As String
Dim pOpenMsgName As OPENFILENAME
Dim rc As Long
Const MAX_BUFFER_LENGTH1 = 256

With pOpenMsgName
    .hInstance = App.hInstance
    .lpstrTitle = "选择 欲嵌入的信息文件"
    .lpstrFile = String(MAX_BUFFER_LENGTH1, 0)
    .nMaxFile = MAX_BUFFER_LENGTH1 - 1
    .lpstrFileTitle = .lpstrFile
    .nMaxFileTitle = MAX_BUFFER_LENGTH1 - 1
'    .flags = OFN_EXPLORER
    .lpstrFilter = "*.*" & Chr$(0) & "*.*" & Chr$(0)
    .lStructSize = Len(pOpenMsgName)
    .hwndOwner = hwnd
    .lpstrInitialDir = "c:\"
End With
preMsgfile = inMsgName
rc = GetOpenFileName(pOpenMsgName)
If rc Then
    inMsgName = pOpenMsgName.lpstrFile
    LabCue2.Caption = "欲嵌入的文件:" & inMsgName
Else
    inMsgName = preMsgfile
End If
TxtName = inMsgName
'取得信息文件的扩展名
Dim tmpname As String
If TxtName <> "" Then
    tmpname = Right$(TxtName.Text, 4)
    If Left$(tmpname, 1) <> "." Then
        MsgBox "该文件名不被支持,请确认文件有且仅有3位扩展名！！！", vbCritical, "错误"
        extName = "msg"
    Else
        extName = Right$(tmpname, 3)
    End If
End If

End Sub

Private Sub cmdopen_Click()
'********************************
'以下使用函数调用打开对话框
Dim preBmpFile As String
Dim pOpenFileName As OPENFILENAME
Dim rc As Long
Const MAX_BUFFER_LENGTH = 256

With pOpenFileName
.hInstance = App.hInstance
.lpstrTitle = "打开 BMP图片"
.lpstrFile = String(MAX_BUFFER_LENGTH, 0)
.nMaxFile = MAX_BUFFER_LENGTH - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = MAX_BUFFER_LENGTH - 1
'.flags = OFN_EXPLORER
.lpstrFilter = "*.bmp" & Chr$(0) & "*.bmp" & Chr$(0)
.lStructSize = Len(pOpenFileName)
.hwndOwner = hwnd
.lpstrInitialDir = "c:\"
End With
preBmpFile = bmpFileName
rc = GetOpenFileName(pOpenFileName)
If rc Then
bmpFileName = pOpenFileName.lpstrFile
Frame1.Visible = True
Else
bmpFileName = preBmpFile
End If
'*****************************
If (bmpFileName <> "") Then
    Open bmpFileName For Binary As #1
     '判断是否是24位色图片
    Dim tag As Integer
    Get 1, 29, tag
    If tag <> 24 Then
    MsgBox "图片不是24位色格式，请选择24位色图片！", vbCritical
    Close #1
    Exit Sub
    End If

    Imagepre.Picture = LoadPicture(bmpFileName)
    LabCue1.Caption = "当前图片:" & bmpFileName
'判断BMP图片中有无信息
    Get 1, 7, haveMsg
    '更改界面
    ''Call changeInterface
    If (haveMsg) Then
        Labtmp.Caption = "图片内有隐藏信息"
        labfinish.Caption = ""
        Get 1, 11, pic_offset
        Get 1, pic_offset + 1, msgs
        extName = Chr$(msgs(0)) & Chr$(msgs(1)) & Chr$(msgs(2))
        outMsgName = outMsgPath & "output." & extName
        LabCue2.Caption = "隐藏信息将被取出到：" & outMsgName
        '是否使用了密码 havepassword=24 有密码
        Get 1, 10, havepassword
        Else
        Labtmp.Caption = "这张图片没有隐藏信息"
        labfinish.Caption = ""
        LabCue2.Caption = "您可以嵌入的信息大小不超过" & Int(LOF(1) / 4092) & "KB"
        End If
    Close #1
End If

End Sub

Private Sub cmdadd_Click()
'******嵌入程序段*******
If (bmpFileName = "") Then
    MsgBox "  请先选择图片！  ", vbCritical, "错误 "
    Exit Sub
End If
If haveMsg Then
    MsgBox "   图片内有隐藏信息，不可嵌入！  ", vbCritical, "错误"
    Exit Sub
End If
If (inMsgName = "") Then
    MsgBox "   请选择要嵌入的信息文件！   ", vbExclamation, "注意"
    Exit Sub
End If
If ChkPassword Then
    If Text1 <> Text2 Then
        MsgBox " 密码不相同！！", vbCritical, "警告！"
        Exit Sub
    Else
    password = Text1
    passwordLen = Len(Text1)
    End If
    havepassword = 24
End If
   MsgBox "    按下[确定]键将开始嵌入信息    ", vbInformation, "准备"
   Call compressHigh
End Sub

Private Sub cmdout_Click()
'******脱壳程序段********
If bmpFileName = "" Then
    MsgBox "    请先选择图片！   ", vbCritical, "错误"
    Exit Sub
End If
If haveMsg = 0 Then
    MsgBox "没有信息可以取出！", vbCritical, "错误"
    Exit Sub
End If
file_len = 0: pic_offset = 0: zlen = 0
outMsgName = outMsgPath & "output." & extName
Open bmpFileName For Binary As #1
Open outMsgName For Binary As #2
'从BMP图片中读取信息长度
Get 1, 7, file_len

'取得版本号
Dim inversion As Long
inversion = file_len And &HF0000000
If inversion <> theVersion Then
    Close #1
    Close #2
    MsgBox "      版本号不同，请升级软件！    ", vbCritical, "注意！"
    Exit Sub
End If
If havepassword = 24 Then
    Get 1, 58, passwordLen
    Dim passOneWord As String * 1, thepassword
    
    While passwordLen
        Get 1, , passOneWord
        thepassword = thepassword & passOneWord
        passwordLen = passwordLen - 1
    Wend
    If thepassword <> InputBox("请输入密码： ", "核实权限") Then
        MsgBox "对不起，您无权取出信息！", vbCritical, "密码不正确"
        Close #1
        Close #2
        Exit Sub
    End If
End If
'取得嵌入方式
MsgBox "   隐藏信息即将取出到：  " & outMsgName, vbInformation, "准备开始"
file_len = file_len And &HFFFFFF
Call unzip_High

MsgBox "信息取出完成！", vbInformation, "完成"
Close #1
Close #2
Dim userSelect
userSelect = MsgBox("     你愿意现在就阅读内容吗？     ", vbQuestion + vbYesNo, "选择")

If (userSelect = 6) Then
    '打开此文件
    Dim rc As Integer
    rc = ShellExecute(0, "open", outMsgName, "", "", SW_SHOWNORMAL)
    userSelect = MsgBox("  不知信息是否对您有用？您想将它删除吗？  ", vbYesNo + vbQuestion, "选择")
    If (userSelect = 6) Then
        DeleteFile outMsgName
        MsgBox outMsgName & "  已删除！", vbInformation, "消息"
    End If
End If
'判断是否清除信息
If clearMsg Then
    Open bmpFileName For Binary As #1
    file_len = 0
    Put 1, 7, file_len
    Close #1
    MsgBox "    信息已清除    ", vbInformation, "消息"
    Labtmp.Caption = "隐藏信息已被清除！"
    LabCue2.Caption = "欲嵌入的文件：无"
    haveMsg = 0
End If
End Sub




Private Sub cmdchgOutPath_Click()
Dim bi As BROWSEINFO, title As String
Dim folder As String, pidl As Long
folder = String$(255, Chr$(0))
With bi
    If IsNumeric(hwnd) Then .hOwner = hwnd
    .ulFlags = &H1
    .pidlRoot = 0
    If title <> "" Then
    .lpszTitle = title & Chr$(0)
    Else
    .lpszTitle = "选择脱壳文件夹" & Chr$(0)
    End If
End With
pidl = SHBrowseForFolder(bi)
If SHGetPathFromIDList(ByVal pidl, ByVal folder) Then
    outMsgPath = Left(folder, InStr(folder, Chr$(0)) - 1)
Else
    outMsgPath = LabOutPath.Caption
End If
If (Right(outMsgPath, 1) <> "\") Then
outMsgPath = outMsgPath & "\"
End If

LabOutPath.Caption = outMsgPath
If haveMsg Then
outMsgName = outMsgPath & "output." & extName
FrmMain.LabCue2.Caption = "隐藏信息将被脱壳到：" & outMsgName
End If

End Sub


Private Sub Form_Load()
theVersion = &H10000000
 
clearMsg = GetSetting(appname:="ZXApp", section:="ShadowInk", _
                       Key:="clearBMP", Default:="0")
outMsgPath = App.Path
If (Right(outMsgPath, 1) <> "\") Then
outMsgPath = outMsgPath & "\"
End If
haveMsg = 0
password = "000000000"
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
'读取注册表参数的操作
ChkclearBmp.Value = GetSetting(appname:="ZXApp", section:="ShadowInk", _
                       Key:="clearBMP", Default:="0")
clearMsg = ChkclearBmp.Value
 
LabOutPath.Caption = App.Path
outMsgPath = LabOutPath.Caption
If (Right(outMsgPath, 1) <> "\") Then
outMsgPath = outMsgPath & "\"
End If

'窗口大小改变相关
InitWidth = ScaleWidth
InitHeight = ScaleHeight
Dim Ctl As Control
' 记录每个 Control 的原始位置、大小、字型大小, 放在 Tag 属性中
On Error Resume Next '确保left, top, width, height, Tag属性没有全有的Control
For Each Ctl In Me   '也能正常执行
    Ctl.tag = Ctl.Left & " " & Ctl.Top & " " & Ctl.Width & " " & Ctl.Height & " "
    Ctl.tag = Ctl.tag & Ctl.FontSize & " "
Next Ctl
On Error GoTo 0


End Sub

Private Sub Form_Resize()
If isExit Then Exit Sub

'窗口改变相关
Dim D(4) As Double
Dim i As Long
Dim TempPos As Long
Dim StartPos As Long
Dim Ctl As Control
Dim TempVisible As Boolean
Dim ScaleX As Double
Dim ScaleY As Double

ScaleX = ScaleWidth / InitWidth
ScaleY = ScaleHeight / InitHeight
On Error Resume Next
For Each Ctl In Me
    TempVisible = Ctl.Visible
    Ctl.Visible = False
    StartPos = 1
    ' 读取 Control 的原始位置、大小、字型大小
    For i = 0 To 4
        TempPos = InStr(StartPos, Ctl.tag, " ", vbTextCompare)
        If TempPos > 0 Then
            D(i) = Mid(Ctl.tag, StartPos, TempPos - StartPos)
            StartPos = TempPos + 1
        Else
            D(i) = 0
        End If
        ' 根据比例设定 Control 的位置、大小、字型大小
        Ctl.Move D(0) * ScaleX, D(1) * ScaleY, D(2) * ScaleX, D(3) * ScaleY
        'Ctl.Width = D(2) * ScaleX
        'Ctl.Height = D(3) * ScaleY
        If ScaleX < ScaleY Then
            Ctl.FontSize = D(4) * ScaleX
        Else
            Ctl.FontSize = D(4) * ScaleY
        End If
    Next i
    Ctl.Visible = TempVisible
Next Ctl
On Error GoTo 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
Close
End Sub



Private Sub Timer1_Timer()
Static asd1 As Integer, asd2 As Integer, asd3 As Integer
Static asd1flag As Boolean, asd2flag As Boolean, asd3flag As Boolean

If asd1flag Then
asd1 = asd1 - 5
Else
asd1 = asd1 + 5
End If
If asd2flag Then
asd2 = asd2 - 2
Else
asd2 = asd2 + 2
End If
If asd3flag Then
asd3 = asd3 - 8
Else
asd3 = asd3 + 8
End If
HScroll1.Value = asd1
HScroll2.Value = asd2
HScroll3.Value = asd3
If asd1 > 200 Then asd1flag = True
If asd1 < 20 Then asd1flag = False
If asd2 > 200 Then asd2flag = True
If asd2 < 16 Then asd2flag = False
If asd3 > 200 Then asd3flag = True
If asd3 < 24 Then asd3flag = False
'Dim a As CommandButton
'
'For Each a In
'a.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
'Next
Gradient FrmMain, HScroll1.Value, HScroll2.Value, HScroll3.Value, asd2flag
'改变按钮颜色
Dim thecorlor As Long
thecorlor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
CmdAbout.BackColor = thecorlor
Cmdexit.BackColor = thecorlor
cmdadd.BackColor = thecorlor
cmdout.BackColor = thecorlor
cmdopen.BackColor = thecorlor
CmdMsgSelect.BackColor = thecorlor
cmdchgOutPath.BackColor = thecorlor
ChkPassword.BackColor = thecorlor
ChkclearBmp.BackColor = thecorlor
End Sub