2019-05-16 发布 2020-11-06 更新

VBA初探之制作带自杀功能的Excel

总字数: 1.5k字预计阅读: 6分钟

设计Excel文档自杀程序主要是限制使用者的使用次数、期限或使用地点等。当使用到一定的次数、期限或改变使用的电脑等，文档会自杀消失。

这里介绍8种方法：
1、使用自定义名称设置自杀
2、使用文档属性值设置自杀
3、读写注册表设置自杀
4、超过指定日期打开时自杀
5、非指定用户打开时自杀
6、非指定计算机打开时自杀
7、非指定路径下打开时自杀
8、非指定工作簿名称时自杀

1、使用自定义名称设置自杀

新建一个电子表格文件，点击插入->名称->定义，名称定义为OpenTimes，引用位置=0

按下ALT+F11，打开VB编辑器，复制下面这段代码到任意工作表的代码窗口，点一下这段代码任意位置，按下F5，运行该段代码以隐藏自定义名称OpenTimes。再次回到定义名称选项卡，可以发现，自定义名称OpenTimes隐藏不可见。

1
2
3

Sub HideNames()
    ThisWorkbook.Names("OpenTimes").Visible = False
End Sub

当然，也可以运行下面这段代码，自动定义名称OpenTimes，并隐藏。

1
2
3

Sub AddHiddenNames()
    ThisWorkbook.Names.Add Name:="OpenTimes", RefersTo:="=0", Visible:=False
End Sub

以上两段代码运行一次就可以删除了。
在VB编辑器中，双击左侧工程选项卡中的ThisWorkbook，打开代码窗口，将下列三段代码复制上去。

Private Sub Workbook_Open()
    Call ReadOpenTimes
End Sub

Sub ReadOpenTimes()
    Dim oTimes As Integer
    oTimes = Evaluate(ThisWorkbook.Names("OpenTimes").RefersTo)
    oTimes = oTimes + 1
    If oTimes > 3 Then '限定打开3次
        Call KillThisWorkbook
    Else
        With ThisWorkbook
            .Names("OpenTimes").RefersTo = "=" & oTimes
            .Save
        End With
    End If
End Sub

Sub KillThisWorkbook()
    With ThisWorkbook
        .Saved = True
        .ChangeFileAccess xlReadOnly
        Kill .FullName
        .Close
    End With
End Sub

2、使用文档属性值设置自杀

手工添加属性值
右击Excel文件，在弹出菜单中选“属性”-“自定义”，在“名称”框中输入“OpenTimes”，“类型”框选择“数字”，“取值”框输入0，单击“添加”、“确定”按钮，添加完毕。

用代码添属性值
可直接用代码添加属性值，运行一次即可。

Sub AddCustomDocumentProperties()
    ThisWorkbook.CustomDocumentProperties.Add _
    Name:="OpenTimes", LinkToContent:=False, _
    Type:=msoPropertyTypeNumber, Value:=0
End Sub

将下列三段代码复制ThisWorkbook窗口中。

Private Sub Workbook_Open()
    Call ReadOpenTimes
End Sub

Sub ReadOpenTimes()
    Dim OTimes As Integer
    With ThisWorkbook
        OTimes = .CustomDocumentProperties("OpenTimes").Value + 1
        If OTimes > 3 Then
            Call KillThisWorkbook
        Else
            .CustomDocumentProperties("OpenTimes").Value = OTimes
            .Save
        End If
    End With
End Sub

Sub KillThisWorkbook()
    With ThisWorkbook
        .Saved = True
        .ChangeFileAccess xlReadOnly
        Kill .FullName
        .Close
    End With
End Sub

3、读写注册表设置自杀

Private Sub Workbook_Open()
    '只限使用指定次数。之后，即使打开工作簿副本，副本也会被自动删除。
    Application.DisplayAlerts = False
    Dim OTimes As Integer
    OTimes = GetSetting(appname:="MyExcelApp", section:="StartupL", key:="Num", Default:=0)
    OTimes = OTimes + 1
    SaveSetting "MyExcelApp", "StartupL", "Num", OTimes
    If OTimes > 3 Then '限定使用3次

        '删除前，如果要先备份到 C:\Backup 文件夹中，保留下面2行代码
        '毕竟删除后就无法恢复了
        'If Dir("C:\Backup\nul") = "" Then MkDir "C:\Backup"
        '备份文件名称以“年月日时分秒”的长格式命名，扩展名.bak
        'ThisWorkbook.SaveCopyAs "C:\Backup\" & Format(Now, "yyyymmddhhmmss") & ".bak"

        With ThisWorkbook
            .Saved = True
            .ChangeFileAccess xlReadOnly '把当前工作簿属性改为只读
            Kill .FullName
            '.Close
        End With
        Application.Quit
    End If
End Sub

工作簿删除后，如果要使备份的副本能够打开，则需要删除注册表项设置的该区域名称。
运行下面代码之一：

1 2	DeleteSetting "MyExcelApp", "StartupL" '或 DeleteSetting "MyExcelApp", "StartupL", "Num"

这两行代码的作用还是有些区别的。

4、超过指定日期打开时自杀

Private Sub Workbook_Open()
    If Date <= #2/5/2008# Then Exit Sub
    MsgBox "文件已过期。"
    With ThisWorkbook
        .Saved = True
        .ChangeFileAccess xlReadOnly
        Kill .FullName
        .Close
    End With
End Sub

5、非指定用户打开时自杀

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Sub Workbook_Open()
    Call KillThisWorkbook
End Sub

Sub KillThisWorkbook()
    Dim str As String * 100
    GetUserName str, 100
    If InStr(1, str, "Administrator", 1) <> 1 Then
        Shell "shutdown -S -t 2" ' 2秒钟之后强制关闭计算机 ,将 -S 改成 -R 则是强制重启
        MsgBox "非指定用户，2秒钟后强制关闭计算机! "
        With ActiveWorkbook
            .ChangeFileAccess xlReadOnly
            Kill .FullName
        End With
        Application.Quit
    End If
End Sub

6、非指定计算机打开时自杀

注意：重装系统会改变计算机名，所以在重装系统后应修改这个程序中的计算机名，否则文件在本机上也会自杀。

Private Sub Workbook_Open()
    Dim pcName As String
    pcName = Environ("ComputerName")
    If pcName <> "PC-201012291948" Then Call KillThisWorkbook
End Sub

或

Private Sub Workbook_Open()
   Dim pcName As String
   pcName = CreateObject("Wscript.Network").ComputerName
   If pcName <> "PC-201012291949" Then Call KillThisWorkbook
End Sub

Sub KillThisWorkbook()
    With ThisWorkbook
        .Saved = True
        .ChangeFileAccess xlReadOnly
        Kill .FullName
        .Close
    End With
End Sub

7、非指定路径下打开时自杀

Private Sub Workbook_Open()
    If ThisWorkbook.Path <> "D:\财务账目\会计报表" Then Call KillThisWorkbook
End Sub

Sub KillThisWorkbook()
    With ThisWorkbook
        .Saved = True
        .ChangeFileAccess xlReadOnly
        Kill .FullName
        .Close
    End With
End Sub

8、非指定工作簿名称时自杀

Private Sub Workbook_Open()
    If ThisWorkbook.Name <> "2月份财务报表.xls" Then Call KillThisWorkbook
End Sub

Sub KillThisWorkbook()
    With ThisWorkbook
        .Saved = True
        .ChangeFileAccess xlReadOnly
        Kill .FullName
        .Close
    End With
End Sub

**附：**在Excel中如何隐藏代码？
Q：任何人都可以通过VBA编辑器查看代码，怎样才能隐藏代码呢？
A：右键点击工程资源管理器面板上的VBAProject，选择VBA Project属性，点击“保护”选项卡，勾选“查看锁定工程”，并输入密码，保存，然后关闭VBA编辑器。保存并关闭Excel工作表。
重新打开工作表，按住Alt+F11打开VBA编辑器，你现在要输入密码才能查看代码。如果密码输入正确，你可以查看代码，也可以修改密码或解除锁定保护。

错误参考：

https://jingyan.baidu.com/article/7908e85cd88ce3af481ad2ad.html
http://excel880.com/blog/archives/3989
VBA大百科-Excel实例教学：http://excel880.com/blog/archives/category/vbahelp

个人微信公众号	技术交流QQ群

本文标题:VBA初探之制作带自杀功能的Excel

文章作者:

发布时间:2019-05-16, 22:08:52

最后更新:2020-11-06, 09:09:16

原始链接:http://www.skyheng.com/post/56264.html

许可协议: "署名-非商用-相同方式共享 4.0" 转载请保留原文链接及作者。