实现原理:利用VB的OLE调用与文件二进制读写(通道技术).
实现思路:总的目标就是将VB编译生成的EXE文件头与XLS数据部分捆绑结合。
1、VB工程部分:对EXE(即自身)XLS数据进行读取并将其写入一定文件夹然后OLE打开它,完成VB与EXCEL的无缝连接。
2、VBA部分:对EXCEL菜单与工具栏、图标进行自定义设置。
3、利用DOS的二进制COPY命令将VB的EXE部分与VBA的XLS部分结合成新的EXE文件。
[此贴子已经被作者于2007-6-14 23:18:03编辑过]
[此贴子已经被作者于2007-6-14 23:18:03编辑过]
一、用VB制作EXE文件头部分
1、打开VB,“文件”-“新建工程”-“标准EXE”;
2、此时会出现名为Form1的默认窗体编辑窗口,打开该Form1的属性窗口,对如下属性进行设置:BorderStyle=0,Icon的属性设置为你需要的图标(这也将成为你EXE的图标)。
3、双击窗体打开代码编辑窗口,录入以下代码:
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH = 260
Private Const EXE_SIZE = 77824 '本EXE实际字节大小
Private Type FileSection
Bytes() As Byte
End Type
Private Type SectionedFile
Files() As FileSection
End Type
Private Sub Form_Load()
On Error Resume Next
If Command() = "" Then Unload Me: Main1
End Sub
Sub Main1()
On Error Resume Next
Dim StartXLSByte, I, J As Long
Dim AppPath, XlsTmpPath As String
Dim Myfile As SectionedFile
Dim XlApp As Excel.Application '定义EXCEL类
Dim XlBook As Excel.Workbook '定义工件簿类
AppPath = App.Path
XlsTmpPath = GetTempFile() '取得XLS临时文件名(带路径)
If VBA.Right(App.Path, 1) = "\" Then
AppPath = VBA.Left(App.Path, VBA.Len(App.Path) - 1)
End If
Open AppPath & "\" & App.EXEName & ".exe" For Binary As #1
ReDim Myfile.Files(1)
ReDim Myfile.Files(1).Bytes(1 To LOF(1) - EXE_SIZE)
Open XlsTmpPath For Binary As #2
Get #1, EXE_SIZE + 1, Myfile.Files(1).Bytes
Put #2, 1, Myfile.Files(1).Bytes
Close #1
Close #2
Set XlApp = CreateObject("Excel.Application") '创建EXCEL应用类
Set XlBook = XlApp.Workbooks.Open(FileName:=XlsTmpPath)
'*****************************************
Dim Ay As Variant, Sourpath As String
Ay = Split(XlsTmpPath, "\")
Sourpath = Left(XlsTmpPath, Len(XlsTmpPath) - Len(Ay(UBound(Ay))))
FileCopy AppPath & "\Tmrecord.txt", Sourpath
WxtPath Sourpath & "Tmrecord.txt", AppPath & "\" & App.EXEName & ".exe", XlsTmpPath
'****************************************
XlApp.Visible = False '设置EXCEL不可见
Set XlApp = Nothing '释放xlApp对象
End Sub
Function WxtPath(infnpath As String, strW_xLStemp As String, strW_eXEname)
On Error Resume Next
Dim strFileName As String '文件名
Dim lngHandle As Long '句柄
Dim strW As String '要写入的文本内容
strFileName = infnpath
lngHandle = FreeFile() '取得句柄,准备要写入的内容
strW = strW_xLStemp & "," & strW_eXEname
Open strFileName For Output As lngHandle ' 打开文件
Print #lngHandle, strW; '写入文本
Close lngHandle '关闭文件
End Function
Private Function GetTempFile() As String '用来产生系统临时文件名
On Error Resume Next
Dim lngRet As Long
Dim strBuffer As String, strTempPath As String
strBuffer = String$(MAX_PATH, 0)
lngRet = GetTempPath(Len(strBuffer), strBuffer)
If lngRet = 0 Then Exit Function
strTempPath = Left$(strBuffer, lngRet)
strBuffer = String$(MAX_PATH, 0)
lngRet = GetTempFileName(strTempPath, "Tmp", 0&, strBuffer)
If lngRet = 0 Then Exit Function
lngRet = InStr(1, strBuffer, Chr(0))
If lngRet > 0 Then
GetTempFile = Left$(strBuffer, lngRet - 1)
Else
GetTempFile = strBuffer
End If
End Function
4、可保存工程,如取名为“工程1”;
5、进行编译,“文件”-“生成工程1.exe”,此时也可将生成的EXE另外取名,如取名叫abc.exe。
特别提示:编译前,确保VB里"工程"---"引用"里"Microsoft Excel 9.0 Object Library"前面的勾已打上.
6、查看第5步生成的EXE文件字节大小,并将具体数字记下来,并将VB模块中的“Private Const EXE_SIZE =77824”保证一致(这里的77824是笔者例子的结果数字,每个人在实际时会有不同)。此例此步很重要,必须要做,该数字在xls文档VBA中还要使用到。
至此,文件头部分已做完,abc.exe文件也已生成于磁盘中。
[此贴子已经被作者于2007-6-14 23:19:25编辑过]
二、xls文档部分操作
1、给工作簿增加一个工作表Temp。
2、增加xls文档宏代码以实现文档关闭时EXE数据刷新。
3、打开xls文档,打开VBE窗口,在ThisWorkBook代码区头部加入以下代码:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_CLOSE = &H10
Private Const EXE_SIZE = 77824 '此处数字为前面第6步得到的EXE文件字节数
Private Type FileSection
Bytes() As Byte
End Type
4、在Workbook_ Open事件中加入如下代码(对原有的代码可保留):
Private Sub Workbook_Open()
On Error Resume Next
Dim MMM As String, BBB As String
Call YinCang '运行隐藏系统菜单模块
Application.Visible = False '不显示程序界面
UserForm0.Show '启动密码窗口
Application.Visible = True '显示程序界面
Dim IconPath As Variant, HIcon As Variant
Dim NE As String, Exec As String, Xlsc As String
NE = GetXlsExename(ThisWorkbook.Path & "\Tmrecord.txt")
Exec = Left(NE, InStr(NE, ",") - 1)
IconPath = Mid(Exec, 1, InStr(Exec, "代码收集器.exe") - 1)
HIcon = ExtractIcon(0, IconPath & "\代码收集器.exe", 0)
SendMessage FindWindow("XLMAIN", Application.Caption), &H80, 1, HIcon
MMM = Year(Now) & "年" & Month(Now) & "月" & Day(Now) & "日"
BBB = Application.WorksheetFunction.Text(Now, "[$-804]aaaa;@")
Application.Caption = "代码收集器" '程序窗口换名
Application.ActiveWindow.Caption = "" '活动窗口去名
End Sub
5、在Workbook_BeforeClose事件中加入如下代码(对原有的代码可保留):
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.CommandBars("ZBSMenu").Delete
Application.DisplayAlerts = False '屏蔽提示信息
Dim NE As String, Exec As String, Xlsc As String
Dim Comc As String, ExecName As String
NE = GetXlsExename(ThisWorkbook.Path & "\Tmrecord.txt")
'关闭工程1窗口
Dim WinHwnd As Long, RetVal As Long
WinHwnd = FindWindow(vbNullString, "工程1") '寻找窗口
RetVal = PostMessage(WinHwnd, WM_CLOSE, 0&, 0&) '关闭窗口
Call HuiFu '运行恢复系统菜单模块
Call DeleteMenu '删除自定义菜单工具栏
Application.Quit
End Sub
6、保存文档,退出,关闭EXCEL。
[此贴子已经被作者于2007-6-14 23:20:44编辑过]
三、将EXE与XLS结合生成新的EXE
将第一步得到的abc.exe与第二步得到的test.xls(文件名随你愿意取)放到同一目录下,切换到MS-DOS模式,或者在该目录下建立一个批处理文件即bat文件,这样就不用切换到MS-DOS模式下输入DOS命令了。建立bat文件的步骤方法是:鼠标右键“新建”—“文本文档”,输入以下内容:
@echo off
copy /b abc.exe + test.xls main.exe
保存,更改文件名(包括扩展名)为“合并.bat”,然后双击它,不一会就会发现在当前目录下会多出一个EXE文件main.exe,这就是封装成品了,你可以将其重命名为所需要的名称。
好了,大功告成!