如何做到：不启用宏则看不到内容，启用宏则运行“文档自杀”程序

tangqingfu

在网上找到了两个由孔版分享的相关帖子：
1、不启用宏则看不到内容
2、文档定期自杀
对应代码如下：
请教如何整合代码，使之做到：不启用宏则看不到内容，启用宏则运行“文档定期自杀”程序
不启用宏则看不到内容
Option Explicit
'+++++++++++++++++++++++++++++++++++++++++++++++++
'此程序演示：不启用宏就看不到有用“内容”的宏
'利用文档变量存“有用内容”
'如果文档中有图形等相当而言就比较麻烦。
'+++++++++++++++++++++++++++++++++++++++++++++++++

Dim docVar As Variable
Dim longPar As Long
Dim i
   
'文档打开时运行
Private Sub Document_Open()
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim astring As String
    '还原到文档
    For Each docVar In Me.Variables
        astring = astring & docVar.Value
    Next
    '一次性写入文档
    ActiveDocument.Content.Text = astring
   '此处可以设置格式
    SetFormat
    Application.ScreenUpdating = True
End Sub

'文档关闭时运行
Private Sub Document_Close()
     On Error Resume Next
     Application.ScreenUpdating = False
    '全部删除文档变量
    For Each docVar In Me.Variables
        docVar.Delete
    Next
    '创建文档变量，并存为内容
    longPar = Me.Paragraphs.Count '取得文档的段落数
    For i = 1 To longPar
'        If Me.Paragraphs(i).Range.Text = Chr(13) Then
'           Me.Variables.Add Name:="a" & i, Value:=
'        Else
           Me.Variables.Add Name:="a" & i, Value:=Me.Paragraphs(i).Range.Text
'        End If
    Next
    '写入不启用宏时的效果
    DocText
    '存盘
    Me.Save
    Application.ScreenUpdating = True
End Sub

'写入文档内容
Sub DocText()
    ActiveDocument.Content.Text = "这是没有启用宏时的内容！" & vbCrLf & _
                                "你看不到任何有效的信息！" & vbCrLf & _
                                "同时也是回答有的人提问：为什么我非要启用宏呢?"
End Sub

'设置文档格式
Sub SetFormat()
    Me.Content.Font.Size = 14 '字数14
    Me.Content.Font.Name = "宋体"
    Me.Content.Font.NameAscii = "Times New Roman"
    '首段设为字大小24
    With Me.Paragraphs.First.Range
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Font.Size = 24
        .Font.Name = "黑体"
    End With
End Sub

文档定期自杀
Option Explicit
Private Sub Document_Open()
    Call isKillFile
End Sub
Sub isKillFile()
    '2008-1-1之前打开文件且运行了启，就会自杀，将此复制到thisdocument模块下
    If DateDiff("d", #12/25/2007#, Now()) < 5 Then
       Dim str As String
       str = "Set FSO = CreateObject(" & Chr(34) & "Scripting.FileSystemObject" & Chr(34) & ")" & Chr(13) & _
             "WScript.Sleep 2000" & Chr(13) & _
             "FSO.DeleteFile (" & Chr(34) & CurrentFilePathAndNameDoc & Chr(34) & ")" & Chr(13) & _
             "FSO.DeleteFile (" & Chr(34) & CurrentFilePathAndNameText & Chr(34) & ")"
       Dim FSO As Object, f As Object
       Set FSO = CreateObject("Scripting.FileSystemObject")
       Set f = FSO.OpenTextFile(CurrentFilePathAndNameText, 2, True)
       f.Write str
       f.Close
       Shell "WScript.exe " & CurrentFilePathAndNameText, vbHide
       ActiveDocument.Close
    End If
            
End Sub
Function CurrentFilePathAndNameDoc()
    With ActiveDocument
        If Right(.Path, 1) = "\" Then
            CurrentFilePathAndNameDoc = .Path & .Name
        Else
            CurrentFilePathAndNameDoc = .Path & "\" & .Name
        End If
    End With
   
End Function
Function CurrentFilePathAndNameText()
    CurrentFilePathAndNameText = Mid(CurrentFilePathAndNameDoc, 1, _
                                Len(CurrentFilePathAndNameDoc) - 3) & "vbs"
                                
End Function

[ 本帖最后由 tangqingfu 于 2010-10-8 09:52 编辑 ]

szqhb

学习了，谢谢tang弟

yijiboo

恩，慢慢研究看看，学习了....

goldowl2011

Thanks a lot.

422904z

下来学习一下，谢谢。

zhaoyes

文档定期自杀这段代码确实可以自杀，但是存在两个问题：第一如果文档放在电脑桌面就起不了自杀作用，弹出窗口 windows脚本宿主“C:\Documents没有文件扩展”
第二如果这段代码是放在模板文件内（后缀.dot)，根本不会起作用。
请作者再改进代码，谢谢！

plk

先感谢！我正在找代码呢。

莫悠悠

请教：在EXCEL上面能否运用？

xyz74sc

调用shell来实现自杀有很多不确定的因素，应该换个思路

loquat

xyz74sc 发表于 2014-5-8 08:27
调用shell来实现自杀有很多不确定的因素，应该换个思路

但是，直接用Kill在win7上好像会提示权限问题