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

  |  

设计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,打开代码窗口,将下列三段代码复制上去。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
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,单击“添加”、“确定”按钮,添加完毕。

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

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

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
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、读写注册表设置自杀

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
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、超过指定日期打开时自杀

1
2
3
4
5
6
7
8
9
10
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、非指定用户打开时自杀

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
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、非指定计算机打开时自杀

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

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
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、非指定路径下打开时自杀

1
2
3
4
5
6
7
8
9
10
11
12
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、非指定工作簿名称时自杀

1
2
3
4
5
6
7
8
9
10
11
12
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编辑器,你现在要输入密码才能查看代码。如果密码输入正确,你可以查看代码,也可以修改密码或解除锁定保护。

错误参考:

个人微信公众号技术交流QQ群
文章目录
  1. 1. 1、使用自定义名称设置自杀
  2. 2. 2、使用文档属性值设置自杀
  3. 3. 3、读写注册表设置自杀
  4. 4. 4、超过指定日期打开时自杀
  5. 5. 5、非指定用户打开时自杀
  6. 6. 6、非指定计算机打开时自杀
  7. 7. 7、非指定路径下打开时自杀
  8. 8. 8、非指定工作簿名称时自杀
  9. 9. 错误参考: