Excel文档自杀程序设计

Excel文档自杀程序设计

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

使用自定义名称设置自杀

运行机理：打开工作薄时激发Open事件，运行“读取打开次数”程序，该过程读取定义的名称opentimes的值，文件每打开一次，opentimes的值在原基础上加1，用If函数判断这个值，如果数值大于100，则运行“自杀”程序消灭文件，如果数值不大于100，原数值加1后保存。

Thisworkbook模块

Private Sub Workbook_Open()

   Call 读取打开次数

End Sub                                                                         

Moudle模块

打开工作簿，选中任意工作表任意一个单元格，执行“插入”-“名称”-“定义”，在“在当前工作簿中的名称”框中输入“opentimes”，在下面的“引用位置”框中输入0，定义完毕。把下面的代码过程放入标准模块中。

Sub 读取打开次数()

  Dim Otime As Integer

  Otime = Evaluate(ThisWorkbook.Names("opentimes").RefersTo)

  Otime = Otime + 1

    If Otime > 100 Then

      Call 自杀

    Else

      ThisWorkbook.Names("opentimes").RefersTo = Otime

      ThisWorkbook.Save

    End If

End Sub                                                                            

Moudle模块

Sub 自杀()

  With ThisWorkbook

    .Saved = True

    .ChangeFileAccess xlReadOnly

    Kill .FullName

    .Close

  End With

End Sub                                                 

隐藏现有自定义名称

当再次执行“插入”-“名称”-“定义”后就会看到原来已插入的名称“opentimes”，如果使用者选中“opentimes”，点击右边的“删除”命令就会把这个名称删掉了，自杀程序就会失败。执行下面的程序把名称隐藏起来就不会出现这种情况了。此程序在定义名称后执行一次即可。

Sub HideNames()

ThisWorkbook.Names("opentimes").Visible = True

End Sub                                                                            

用代码添加隐藏的自定义名称

也可编码直接定义隐藏的名称。

Sub AddHiddenNames()

  ThisWorkbook.Names.add Name:="opentimes",RefersTo:="=0",Visible:=False

End Sub                                                                       

使用文档属性值设置自杀

运行机理：与使用自定义名称设置自杀过程相同，只不过读取的不是自定义名称的值而是文档属性的值。“自杀”的程序也相同

Thisworkbook模块

Private Sub Workbook_Open()

  Call 读取打开次数

End Sub                                                                         

Sub 读取打开次数()

  Dim Otime As Integer

    Otime = ThisWorkbook.CustomDocumentProperties("opentimes").Value

    Otime = Otime + 1

      If Otime >100 Then

        Call 自杀

      Else

        ThisWorkbook.CustomDocumentProperties("opentimes").Value = Otime

        ThisWorkbook.Save

   End If

End Sub                                                                               

Moudle模块

Sub 自杀()

  With ThisWorkbook

    .Saved = True

    .ChangeFileAccess xlReadOnly

    Kill .FullName

    .Close

  End With

End Sub                                                         

添加属性值

打开Excel文件，点击“文件”-“属性”-“自定义”，在“名称”框中输入“opentimes”，“类型”框选择“数字”，“取值”框输入0或1，单击“”添加、“确定”按钮，添加完毕。

用代码添属性值

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

Sub addCustomDocumentProperties()

  ThisWorkbook.CustomDocumentProperties.add _

  Name:="opentimes", _

  LinkToContent:=False, _

  Type:=msoPropertyTypeNumber, _

  Value:=0

End Sub                                                                   

自杀前备份同名文件

如果不想让文件真的完全灭失，可编码在文件自杀前拷贝到只有自己知道的文件夹内。

Private Sub Workbook_Open()

  Call 读取打开次数

  Dim Otime As Integer

  Dim Name As String

  With ThisWorkbook

    Otime = .CustomDocumentProperties("opentimes").Value

    If Otime = 98 Then

      ActiveWorkbook.SaveCopyAs"c:\Program Files\Microsoft Office" & "" & ThisWorkbook.Name

    End If

  End With

End Sub                                                                            

使用日期设置定时自杀

运行机理：打开工作簿时运行Open事件，用Date方法读取系统当前日期，使用If函数判断当前日期的值与设置自杀的值是否相符，符合条件时启动“自杀”程序。如设置2010年12月1日后文档自杀，2010年12月1日的序列值是40513（使用1900年日期系统），那么使用以下程序，12月1日后何时打开，文件都会自杀。

Thisworkbook模块

Private Sub Workbook_Open()

  If Date>40513 then

    Call 自杀

  End If

End Sub                                                                        

Moudle模块

Sub 自杀()

  With ThisWorkbook

  .Saved = True

  .ChangeFileAccess xlReadOnly

  Kill .FullName

  .Close

  End With

End Sub                                             

使用文件路径设置自杀

运行机理：打开工作簿时运行Open事件，使用If函数判断文件的路径与原始存储路径是否相符，否则就自杀。此程序防止把文件复制或移动到其他地方使用。

Thisworkbook模块

Private Sub Workbook_Open()

If ThisWorkbook.Path <> "D:\财务账目\会计报表" Then Call delt  '自杀程序

End Sub                                                                         

Moudle模块

Sub delt()    '自杀程序，与上一个自杀程序基本相同

Application.DisplayAlerts = False

ActiveWorkbook.ChangeFileAccess xlReadOnly

Kill ActiveWorkbook.FullName

Application.Quit   ’连程序一块关闭

End Sub                                                                 

使用计算机名设置自杀

运行机理：打开工作簿时运行Open事件，使用If函数判断文件是否在本机上运行，否则就自杀。此程序防止把文件复制或移动到其他计算机使用。重装系统会改变计算机名，所以在重装系统后应修改这个程序中的计算机名，否则文件在本机上也会自杀。

Private Sub Workbook_Open()

pcname = Environ("ComputerName")

If pcname <> "PC-201012291949" Then Call delt

End Sub                                                                       

或

Private Sub Workbook_Open()

pcname = CreateObject("Wscript.Network").ComputerName

If pcname <> "PC-201012291949" Then Call delt

End Sub                                                                       

 使用文件名称自杀

运行机理：打开工作簿时运行Open事件，使用If函数判断文件名称。此程序防止把文件复制到下月份或年份或其他名称的文件继续使用。如果要修改文件名称，则应先停止程序运行，改名后修改程序中的相应名称，否则文件会自杀。

Private Sub Workbook_Open()

If ThisWorkbook.Name <> "2月份财务报表.xls" Then Call dele

End Sub                                                                         

 [e-mail]