加载宏EXE安装程序制作及Excel区域锁定功能小程序开发分享

XIAORW

菜鸟学习VBA之Excel任意区域锁定功能小程序开发过程-附源码(之前的标题，现改了，希望有人关注)
本人工作原因常常与数据打交道，尤其Excel几乎天天接触，用到的都是基本功能都是重复性的操作——输入数据，添加函数公式、复制，选择性粘贴，转置、保存、另存为等等。
我是2015年开始接触VBA的，契机是我们领导想在一个表格中对于小于0.3的值则显示“<0.3”,大于则不显示。原我知道可以用if函数做到，然而包含一个公式在单元格里总是那么不爽，而且这个表格需要多次复制，粘贴进行其他处理，总之不完美。如果靠手工一个个去修改，估计眼睛都会看花，挂一漏万是绝对不允许的。于是想到向学计算机的朋友请教，结果人家让我打开开发工具，一句代码就搞定了。这时我才知道原来Excel还有开发工具这玩意，也开始对编程有所认识。对VBA产生了浓厚兴趣，慢慢利用工作之余开始各种菜鸟式的学习。
废话打住，言归正题。因为工作原因，我们同事常常需要在一张已经输入很多公式的表格中输入当天测定的数据进行一些算较为复杂的计算，然后，誊抄计算结果等等重复性的工作。按说没什么，然而由于有些同事年龄较大或者本身只会Excel的一些基本操作，不会也不想懂Excel表格里的那些复杂的英文公式，也不是很清楚引用单元格是什么玩意。所以经常鼠标一不小心点到（双击）带公式的单元格，然后又点击了旁边不该引用的单元格，然后出现一堆“？#￥”的时候，就会大叫，电脑坏掉了，然后就坐等处理。有时候很是麻烦，还埋怨制作表格的人搞得太复杂，装逼。
于是我就得做点事解决这个问题，想到excel的protect功能可以实现一些区域的加密锁定而且还相对较为安全，然而因为使用表格的人涉及到比较多，年龄层次各异，而且其中的一些数据常常需要某个具体负责人进行定期更新。尤其我对于用户双击被保护区域那个长长的弹框实在很烦。于是我想自己写一个类似的更简单容易操作的加密锁定功能。于是
开始设想：见图3

几经修改与折腾，得以完成。模块中源码见附件吧：
类模块“mycls”中
Option Explicit
Public WithEvents myapp As Excel.Application
Public psdshname As String
Private Sub myapp_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim rng1 As Range
Dim lockdrs As Range
Dim inputstr As String
Dim shdata As Worksheet
On Error Resume Next
Set shdata = ActiveWorkbook.Worksheets("Datasheet")
If shdata Is Nothing Then
  Exit Sub
  Else:
    For Each lockdrs In shdata.Range("C1:C" & shdata.Range("C1000").End(xlUp).Row)
            If lockdrs.Value = Sh.CodeName Then
                 If Not Intersect(Target, Range(shdata.Range("B" & lockdrs.Row).Value)) Is Nothing Then
                    Cancel = True
                    If MsgBox("单元格被锁定，禁止修改，是否解锁？", vbYesNo) = vbYes Then
                        Do
                        inputstr = Application.InputBox("请输入密码:", "单元格解除锁定", Type:=1 + 2)
                            If inputstr <> "" And inputstr <> "False" Then
                                If inputstr = shdata.Range("A" & lockdrs.Row).Value Then
                                    shdata.Rows(lockdrs.Row).Delete
                                Else: MsgBox "密码错误,请重新输入", vbOKOnly
                                End If
                            ElseIf inputstr = "" Then
                                MsgBox "密码不能为空，请重新输入", vbOKOnly
                            Else: Exit Do
                                  Exit Sub
                            End If
                        Loop Until inputstr = shdata.Range("A" & lockdrs.Row).Value
                    End If
                 End If
             End If
      Next
End If
End Sub
Private Sub myapp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rng1 As Range
Dim lockdrs As Range
Dim locksh As String '
On Error Resume Next
If ActiveWorkbook.Worksheets("Datasheet") Is Nothing Then
    Exit Sub
Else:
    If Sh.CodeName <> "" Then
        For Each lockdrs In Worksheets("Datasheet").Range("C2:C" & Worksheets("Datasheet").Range("C1000").End(xlUp).Row)
            If lockdrs.Value = Sh.CodeName Then
                If Not Intersect(Target, Range(Worksheets("Datasheet").Range("B" & lockdrs.Row).Value)) Is Nothing Then
                        MsgBox "单元格禁止修改"
                        Application.EnableEvents = False
                            Application.Undo
                        Application.EnableEvents = True
                End If
            End If
        Next
    End If
End If
End Sub

由于功力不够，写代码过程中遇到各种问题，一些是自己考虑不够周全，一些是自己没想到的。列举几个如下：
1.        首先是发现用户只要修改了表格名称，功能就失效
2.        用到sheet的codename去解决问题1的时候，发现不激活vba工程是无法获取codenamed。
3.        虽然激活了vba工程，但如果不开启信任对VBA工程的访问也是没用的。
4.        如何把功能发给其他有相同需求的同仁们使用？涉及到启用宏的等级问题。加载宏列表里呈现的加载宏名似乎是不区分大小写的，而宏文件名本身是会区分的。
5.              锁定的区域如果交叉怎么处理？
6.        类模块中事件继承（用词可能不准确），发现单击事件是先于双击事件发生的也是我没考虑到的，程序呈现了bug才知道。
7.        如何制作成简单的exe安装文件，代码如何写？
8.        卸载文件代码如何写？
等等问题，虽然是一个很简单的功能，然而对于我这种接触VBA时间不久和悟性较差的菜鸟来说，写代码的过程中遇到的问题实在太多。然而，最终总算靠自己全部解决了（没有发帖求助过），但是，不得不说，我受到过本论坛的各位前辈的帮助非常之多。我认真读过yuanzhuping老师写的电子版本的书，学习过赵老师的VBA视频讲解，以及佛山小老鼠老师的视频和原创帖（得到过他的很多帮助），还有蓝桥玄霜老师的，拜读过各大版主、超级版主、离人版主的代码。由于平日工作忙碌，没能在读到上述各位老师的佳作后回帖说声感谢，真心有愧。
为了一起学习，感谢论坛带给我的帮助，互相进步，我决定把install.exe 与uninstall.exe以及加载宏中的源代码一起公布。代码等格式写得很不规范，还请海涵，一些未使用的代码只是加了注释，并未删除。
如有更好的建议和意见，欢迎留言反馈，不胜感激。
另外我本想写段代码，实现禁止当用户取消勾选加载宏文档，始终难以实现。若有方家可解决这个问题，若有方家可解决，期待留言啊。感激不尽。
然而我想我的这个小功能本就不是图安全（protect比我这都要好），而是图使用方便。因此我想说明的是我这个功能主要是方便包含公式或不想被人随意修改的区域的暂时性本机本地的简单加密锁定。
原本也想通过Excel protect功能写一个类似更方便操作和使用的程序，然而始终有个问题没解决，就是用户直接通过Excel编辑区编辑锁定单元格内容的时候依然弹出那个长的警示框（双击可通过cancel参数达到屏蔽那个警示框的效果），若有方家可解决，期待留言。
注：excel 2007以上个性功能区的打造参看佛山小老鼠的原帖，论坛可搜
       很多代码参考了很多前辈，在此一一谢过。
install的EXE文件是vb6里编写的，创建标准exe，删除form1模块，添加标准模块，添加引用，输入代码，生成exe。
最终的exe安装文件，是通过WinRAR打包成自解压文件exe文件制作的，方法简单，一看就懂的。

随心_201320085

感谢楼主分享，建议上传分享附件！

XIAORW

随心_201320085 发表于 2016-1-14 22:28
感谢楼主分享，建议上传分享附件！

刚正在上传，网络太慢了。哈哈

XIAORW

install.exe文件安装完成，会自己删除自己。uninstall.exe运行后也会删除自己以及安装目录和addins下的加载宏宏和相关文件。
本程序适合excel2003-2016非免安装（无注册表项目）的各个版本，win64位未测试。
install.exe 源码：
Private Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long‘声明删除install.exe自身的一个函数，原本可以通过调用vbs或者批处理可以达到，这个简单，也是参考网上一位前辈的代码
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)’声明sleep函数
Private Declare Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long, ByVal wlange As Long, ByVal dwTimeout As Long) As Long‘声明messageboxtimeout函数，可实现定时关闭msgbox消息框，关键是其关闭的时间是以毫秒计算的。比wsh.popup更方便。
Sub Main()
On Error Resume Next
'Dim Wsh As Object
'Set Wsh = CreateObject("Wscript.Shell")
Dim xlapp As Object 'Excel对象
Set xlapp = CreateObject("Excel.application")
versNo = xlapp.Version’excel版本号

MessageBoxTimeout hwnd, "当前可安装功能的Microsoft Excel版本是" & versNo & "，安装正在倒计时。", "安装完成提示", vbInformation, 0, 1600

If versNo = "15.0" Then‘excel2013 宏安全性设置在注册表中的位置与其他版本不一样。一下代码通过修改注册表 更改excel宏安全等级为低。安装完成后会恢复默认等级-中
RegStr1 = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\" & versNo & "\Excel\Security\VBAWarnings"
RegStr2 = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\" & versNo & "\Excel\Security\Level"
RegStr3 = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\" & versNo & "\Excel\Security\AccessVBOM"
Else:
RegStr1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & versNo & "\Excel\Security\VBAWarnings"
RegStr2 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & versNo & "\Excel\Security\Level"
RegStr3 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & versNo & "\Excel\Security\AccessVBOM"
'RegStr4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & versNo & "\Excel\Security\AccessVBOM"
End If
levelNo = Wsh.RegRead(RegStr2) '读取当前安全级别
levelNo = Wsh.RegWrite(RegStr1, "1", "REG_DWORD") 'VBA安全级别值1-4分别对应：低，中，高，非常高
levelNo = Wsh.RegWrite(RegStr2, "1", "REG_DWORD")
VBcomtrust = Wsh.RegWrite(RegStr3, "1", "REG_DWORD") '添加VBA工程信任
'VBcomtrust = Wsh.RegWrite(RegStr4, "1", "REG_DWORD")
Dim fso
Set fso = CreateObject("Scripting.FilesyStemObject")’创建fso对象，针对不同版本的excel进行加载宏操作
Select Case versNo
Case Is = "11.0"
Dim mbtn As Object
Dim mbtns As Object
On Error Resume Next
xlapp.CommandBars("worksheet menu bar").Controls("帮助(&H)").Controls("表格区域加密（L）").Delete‘以下在excel2003中帮助菜单下创建菜单按钮。
Set mbtn = xlapp.CommandBars("worksheet menu bar").Controls("帮助(&H)")
        With mbtn
            .Controls.Add(Type:=msoControlPopup, before:=1).Caption = "表格区域加密（L）"
        End With
        Set mbtns = xlapp.CommandBars("worksheet menu bar").Controls("帮助(&H)").Controls("表格区域加密（L）")
        With mbtns
            .Controls.Add(Type:=msoControlButton, before:=1).Caption = "区域加密"
            .Controls("区域加密").FaceId = 107
            .Controls("区域加密").OnAction = "safeback"
            .Controls.Add(Type:=msoControlButton, before:=2).Caption = "区域解锁"
            .Controls("区域解锁").OnAction = "safeopen"
            .Controls("区域解锁").FaceId = 144
        End With
sfile = App.Path & "\LockedAreas.xla"’复制安装包里的加载宏文档到默认加载宏路径，并自动加载
despath = xlapp.UserLibraryPath‘office加载宏默认目录，非常好用的方法
fso.CopyFile sfile, despath
xlapp.Visible = False
     xlapp.AddIns.Add FileName:=despath & "LockedAreas.xla"
     xlapp.AddIns("Lockedareas").Installed = 1
xlapp.Quit
Case Is > "11.0"
sfile = App.Path & "\Lockedareas2007.xlam"
despath = xlapp.UserLibraryPath
fso.CopyFile sfile, despath
xlapp.Visible = False
     xlapp.AddIns.Add FileName:=despath & "Lockedareas2007.xlam"‘2007以上版本的加载宏自动加载
     xlapp.AddIns("Lockedareas2007").Installed = True
xlapp.Quit
End Select
'
levelNo = Wsh.RegWrite(RegStr1, "2", "REG_DWORD") ’恢复宏安全等级
levelNo = Wsh.RegWrite(RegStr2, "2", "REG_DWORD")
Set sfile1 = fso.getfile(App.Path & "\LockedAreas.xla")
Set sfile2 = fso.getfile(App.Path & "\LockedAreas2007.xlam")
    sfile1.Attributes = 0
    sfile2.Attributes = 0
    sfile1.Delete
    sfile2.Delete
MessageBoxTimeout hwnd, "功能安装成功", "完成提示", vbInformation, 0, 820'安装成功

Set xlapp = Nothing
Set xlbook = Nothing
Set fso = Nothing
Set Wsh = Nothing

Sleep (300)

WinExec "cmd /c ping 127.0.0.1 -n 2 && del /q """ & App.Path & "\" & App.EXEName & ".exe""", vbHide ' 删除安装文件-install.exe

End Sub

XIAORW

卸载uninstall.exe源码:
Private Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long‘声明api函数，用于卸载完后删除uninstall.exe文件。
Private Declare Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long, ByVal wlange As Long, ByVal dwTimeout As Long) As Long‘声明api函数，用于弹出定时自动关闭的messageboxtimeout消息框。
Sub Main()
On Error Resume Next
If MsgBox("卸载前，请手动关闭所有运行的Microsoft Excel,否则将自动关闭。按确定继续卸载，按取消退出卸载", vbOKCancel) = vbOK Then’卸载前需要关闭所有正在运行的Excel程序，否则加载宏文档正在使用，会导致无法删除。messageboxtimeout消息框。
Set killproces = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("select * from win32_process where name='Excel.exe'")‘获取进程列表中excel进程
For Each proce In killproces
    proce.Terminate’结束进程
Next
Else: Exit Sub
End If

Set xlapp = CreateObject("Excel.application")‘创建excel对象
Dim fso As Object
Set fso = CreateObject("Scripting.FilesyStemObject")
versNo = xlapp.version
If versNo = "11.0" Then
    xlapp.CommandBars("worksheet menu bar").Controls("帮助(&H)").Controls("表格区域加密（L）").Delete’删除Excel2003版本由加载宏创建的菜单
    If Err Then
        MessageBoxTimeout hwnd, "未安装相应功能，无需卸载", "卸载提示", vbInformation, 0, 1200
        Exit Sub
    End If
    xlapp.Visible = False‘使创建的Excel对象不可见
    xlapp.AddIns("Lockedareas").Installed = False’取消勾选加载项
    xlapp.Quit‘ 关闭创建的Excel对象

Set sfile = fso.getfile(xlapp.UserLibraryPath & "\LockedAreas.xla")’以下代码删除默认加载宏目录下相应的excel加载宏文档

    sfile.Attributes = 0
    sfile.Delete

Else:
    xlapp.Visible = False‘excel2007以上版本取消勾选加载宏并删除相应加载宏文档
    xlapp.AddIns("Lockedareas2007").Installed = False
    If Err Then
        MessageBoxTimeout hwnd, "未安装相应功能，无需卸载", "卸载提示", vbInformation, 0, 1200
        xlapp.Quit
        Exit Sub
    End If
Set sfile = fso.getfile(xlapp.UserLibraryPath & "\Lockedareas2007.xlam")

    sfile.Attributes = 0
    sfile.Delete
End If
    MessageBoxTimeout hwnd, "卸载完成", "卸载提示", vbInformation, 0, 980

Set dfile = fso.getfile(App.Path & "\LockedAreasforExcel.ico") '删除卸载快捷方式图标
    dfile.Attributes = 0
    dfile.Delete
   
    WinExec "cmd /c ping 127.0.0.1 -n 2 && del /q """ & App.Path & "\" & App.EXEName & ".exe""", vbHide ' 删除卸载文件uninstall.exe
   
End Sub

liucqa

支持一下。。。。。。。

XIAORW

liucqa 发表于 2016-1-15 11:49
支持一下。。。。。。。

谢谢高手的鼓励

lzqlaj

支持原创。

咸味

留下脚步学习