Excel文档自杀程序设计

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

使用自定义名称设置自杀

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

Thisworkbook模块

Private SubWorkbook_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

EndSub                                                                           

Moudle模块

Sub自杀()

  WithThisWorkbook

   .Saved = True

   .ChangeFileAccess xlReadOnly

   Kill .FullName

   .Close

  EndWith

EndSub                                                 

隐藏现有自定义名称

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

SubHideNames()

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

EndSub                                                                           

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

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

SubAddHiddenNames()

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

EndSub                                                                      

使用文档属性值设置自杀

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

Thisworkbook模块

Private SubWorkbook_Open()

  Call读取打开次数

EndSub                                                                        

Sub读取打开次数()

  Dim OtimeAs Integer

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

   Otime = Otime + 1

     If Otime >100 Then

       Call 自杀

     Else

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

      ThisWorkbook.Save

  End If

EndSub                                                                              

Moudle模块

Sub 自杀()

  With ThisWorkbook

   .Saved = True

   .ChangeFileAccess xlReadOnly

   Kill .FullName

   .Close

  End With

EndSub                                                         

添加属性值

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

用代码添属性值

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

SubaddCustomDocumentProperties()

 ThisWorkbook.CustomDocumentProperties.add _

 Name:="opentimes", _

 LinkToContent:=False, _

 Type:=msoPropertyTypeNumber, _

 Value:=0

EndSub                                                                  

自杀前备份同名文件

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

Private SubWorkbook_Open()

  Call读取打开次数

  Dim OtimeAs Integer

  Dim NameAs String

  WithThisWorkbook

   Otime =.CustomDocumentProperties("opentimes").Value

   If Otime = 98 Then

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

   End If

  EndWith

EndSub                                                                           

使用日期设置定时自杀

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

Thisworkbook模块

Private SubWorkbook_Open()

  IfDate>40513 then

   Call 自杀

  EndIf

EndSub                                                                       

Moudle模块

Sub自杀()

  WithThisWorkbook

  .Saved =True

 .ChangeFileAccess xlReadOnly

  Kill.FullName

 .Close

  EndWith

EndSub                                             

使用文件路径设置自杀

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

Thisworkbook模块

PrivateSub Workbook_Open()

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

End Sub                                                                         

Moudle模块

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

Application.DisplayAlerts = False

ActiveWorkbook.ChangeFileAccessxlReadOnly

KillActiveWorkbook.FullName

Application.Quit  ’连程序一块关闭

EndSub                                                                 

使用计算机名设置自杀

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

PrivateSub Workbook_Open()

pcname= Environ("ComputerName")

Ifpcname <> "PC-201012291949" Then Calldelt

EndSub                                                                       

或

PrivateSub Workbook_Open()

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

Ifpcname <> "PC-201012291949" Then Calldelt

EndSub                                                                       

 使用文件名称自杀

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

PrivateSub Workbook_Open()

IfThisWorkbook.Name <> "2月份财务报表.xls" Then Calldele

EndSub                                                                        

 [e-mail]