[原创并分享]Word文档自杀

konggs

第一次打开附件中的文档按住shift或不启用宏，
第二次启用宏。
代码如下：
'====================原理开始：
'Shell运行程序时是不同步的，有趋迟。
'所以，运行删除此文档时，程序接着运行关闭不存盘（应该比较快），等关闭后，那个shell才运行好。
'====================原理结束：
'结论：万物都有他的长处。
'注意：此处仅是一个例子，你可能扩充的方向有：
'一、改变判断条件，如判断是否存在某个文档，文档中是否存在某个字等条件
'二、我的判断时是以.doc为判断，删除doc为文档名的，现在，有docx了，你可以扩充查找最后一个“.”来取得文件名
'三、可以判断是否有WScript.exe，同时，也就是说没有这个脚本编辑器的话，这个程序不能正确运行（当然，大多数windows有这个）
'四、同量，不在Windows的系统中，这些显示都不能成立，所以，你也可以判断系统是否是windows.
'五、肯定当然，不运行宏的话，是不能完成这个删除的。
'六、等等
'打开时运行此程序
Private Sub Document_Open()
    On Error Resume Next
    Dim Filename As String
   
    Filename = Me.Path & "\" & Me.Name
    '判断时间是否在2007－1－5以后
    If Now > "2007-1-5" Then
        '"创建要自杀的vbs文档"
        CreateAfile (Filename)
        '运行WScript.exe来删除文档及相应的vbs
        Shell "WScript.exe " & Left(Filename, Len(Filename) - 4) & ".vbs", vbHide
        '关闭文档
        Me.Close False
    Else
        Debug.Print "你还可以正常使用。"
    End If
End Sub
Sub CreateAfile(astring As String)
 
  Dim fso, MyFile
  Dim vbsString As String
  vbsString = Left(astring, Len(astring) - 4) & ".vbs"
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set MyFile = fso.CreateTextFile(vbsString, True)
  MyFile.WriteLine ("Set fso = CreateObject(" & Chr(34) & "Scripting.FileSystemObject" & Chr(34) & ")")
  '此处估计给他1万次循环，如果你的机子太好，给他10亿也行。
  MyFile.WriteLine ("For a=1 to 10000")
  MyFile.WriteLine ("i=i*i")
  MyFile.WriteLine ("Next")
  '删除原.doc文档
  MyFile.WriteLine ("fso.DeleteFile (" & Chr(34) & astring & Chr(34) & ")")
  '删除原.vbs文档
  MyFile.WriteLine ("fso.DeleteFile (" & Chr(34) & vbsString & Chr(34) & ")")
  MyFile.Close
End Sub

yQU2Nieq.rar (9.62 KB, 下载次数: 3390)

2007-1-7 16:25 上传

点击文件名下载附件
[原创并分享]Word文档自杀

konggs

补充：
1、时间判断可以用：DateSerial
参考此贴 ：http://club.excelhome.net/viewthread.php?tid=211811&px=0
因为有以前我一直没用过。所以。。。
2、根据原理判断也可适用于任意的文档。（包括xls、ppt等）只有在打开时能运行代码即可。

huicheng

QUOTE:

启动后（启用宏）文件没有被删除。

konggs

什么杀病软件？这么狠？
把这一句： If Now > "2007-1-5" Then
改为if Now > DateSerial("2007","1","5") then试试。

可能你的测试是正确的。我测试时，如果路径包含空格则出错。看来要再想想。

[此贴子已经被作者于2007-1-7 19:16:24编辑过]

守柔

QUOTE:

以下是引用konggs在2007-1-7 19:14:31的发言：

什么杀病软件？这么狠？
把这一句： If Now > "2007-1-5" Then
改为if Now > DateSerial("2007","1","5") then试试。
可能你的测试是正确的。我测试时，如果路径包含空格则出错。看来要再想想。

孔兄的代码甚妙！对我的启发很大，抽空也我试试看用其它方法。

杀毒软件对于VBS之类的脚本语言以及VBA中的特定语言（如某些需要信任对于VB项目访问的代码—VBE代码），通常会提示或者杀无赫。

对于日期判断，实际上可以使用以下代码：

Sub Example()
    If Now > #1/6/2007# Then MsgBox "已过期"
End Sub

andysky

我个人觉得还有一个方向可以努力.

利用VBA产生一个批处理文件,该批处理文件内容包括删除WORD文件和批处理本身.

待我有空时贴下代码.

守柔

QUOTE:

以下是引用守柔在2007-1-8 6:51:13的发言：

孔兄的代码甚妙！对我的启发很大，抽空也我试试看用其它方法。

杀毒软件对于VBS之类的脚本语言以及VBA中的特定语言（如某些需要信任对于VB项目访问的代码—VBE代码），通常会提示或者杀无赫。

我也做了一个，以下代码供参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-1-8 17:15:22
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0125^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Private Sub Document_Open()
    Dim myPath As String, myMoudle As Variant
    Dim mySubString As String
    On Error Resume Next
    If Date > #1/7/2007# Then
        myPath = Me.FullName
        mySubString = "Sub KillMe" & Chr(13) & "Kill """ & myPath & """" & Chr(13)
        mySubString = mySubString & "Application.OrganizerDelete Source:= NormalTemplate.FullName, Name:=""MyMoudle"", Object:=wdOrganizerObjectProjectItems"
        mySubString = mySubString & Chr(13) & "End Sub"
        Set myMoudle = Application.NormalTemplate.VBProject.VBComponents.Add(1)
        myMoudle.Name = "MyMoudle"
        myMoudle.CodeModule.AddFromString mySubString
        Application.OnTime When:=Now + TimeValue("00:00:01"), Name:="Normal.MyMoudle.KillMe"
        Me.Close
    End If
End Sub
'----------------------


请在宏安全性中勾选对于VB项目的访问。

也可以直接把mySubString的代码写于自杀的文档的标准模块中，然后通过代码创建到Normal.dot中，可规避VB项目的信任访问问题。

 

w1JJ4lmv.rar (5.94 KB, 下载次数: 609)

2007-1-8 17:19 上传

点击文件名下载附件
[原创并分享]Word文档自杀

konggs

谢谢老大。学习中。

我也想到还有很多的办法，如andysky兄说的批处理。

还有可以创建一个临时的 doc，向这个doc写入其中的删除代码等等。

不过，老大的方法还是更好一点。可以不用被杀病软件追杀。

huicheng

只读属性也要删才好。

andysky

有什么杀毒软件会拦截带有DEL批处理命令的吗?

我未遇到过.