<?xml version="1.0" encoding="utf-8" ?>
<package xmlns="http://schemas.microsoft.com/WindowsScriptHost">
  <job>
    <script language="VBScript">
      <![CDATA[
' 指定段落添加内容并格式化
On Error Resume Next
Const wdReplaceAll = 2
Const wdStory = 6
Const wdRed = 6
Const wdAuto = 0
Const wdCharacter = 1
Const wdCollapseEnd = 0
Const wdCollapseStart = 1
Const wdAlignParagraphLeft = 0
Const wdAlignParagraphCenter = 1
Const wdAlignParagraphRight = 2
Const wdAlignParagraphJustify = 3
Const wdAlignParagraphDistribute = 4
Const wdAlignParagraphJustifyMed = 5
Const wdAlignParagraphJustifyHi = 7
Const wdAlignParagraphJustifyLow = 8
Const wdAlignParagraphThaiJustify = 9
Const conExtension = "|docx|"
Const conSrcDir = "d:\test\word\作业" ' 作业目录
Const conRecurse = 0 '是否递归子目录,是=1,否=0
' 强制以cscript.exe运行 WSH
RunasScriptHost "cscript.exe"
WScript.StdOut.WriteLine "脚本执行中,请稍等...,不要重复执行脚本."

Dim dtm,strDtm,wordApp,fso,srcDir,dstDir
dtm = Now
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.Application")
wordApp.DisplayAlerts = False
If Err.Number <> 0 Then
  MsgBox Err.Description
  WScript.Quit 1
End If
srcDir = fso.GetAbsolutePathName(conSrcDir)
If Not fso.FolderExists(srcDir) Then
  WScript.Echo "目录: " & srcDir & " 不存在."
Else
  GenFolder fso.GetFolder(srcDir)
End If
wordApp.Quit
MsgBox "Done."
Set wordApp = Nothing
Set fso = Nothing

Sub GenFolder(oFolder)
  On Error Resume Next
  Dim oFile,oSubFolder
  For Each oFile In oFolder.Files
    If InStr(1,conExtension, "|" & fso.GetExtensionName(oFile.Name) & "|", vbTextCompare) > 0 Then
      GenFile oFile
    End If
  Next
  If conRecurse = 1 Then
    For Each oSubFolder In oFolder.SubFolders
      GenFolder oSubFolder
    Next
  End If
End Sub
Sub GenFile(oFile)
  On Error Resume Next
  Dim docSrc,orange,oPara
  Set docSrc = wordApp.Documents.Open(oFile.Path)
  If docSrc Is Nothing Then Exit Sub
  Set oPara = docSrc.Paragraphs(10)
  if not oPara is nothing then 
  With opara
    .Range.InsertBefore "批处理之家"
    .Alignment = wdAlignParagraphRight
  End With
  end if 
  set opara = nothing
  set opara = docSrc.Paragraphs(132)
  if not opara is nothing then 
  With opara
    Set orange = .Range
    orange.Collapse wdCollapseStart
    orange.InsertBefore "批处理之家"
    orange.Collapse wdCollapseEnd
    orange.InsertDateTime "yyyy-MM-dd", False
    .Alignment = wdAlignParagraphLeft
  End With
  end if 
  set opara = nothing
  set opara = docSrc.Paragraphs(56)
  if not opara is nothing then
  With opara
    .Range.InsertBefore "批处理之家"
    .Alignment = wdAlignParagraphDistribute
    .FirstLineIndent = 0
    .IndentFirstLineCharWidth 2
  End With
  end if
  set opara = nothing
  docSrc.Save
  docSrc.Close
End Sub

  Sub RunasScriptHost(strWSH)
    ' runas cscript.exe or wscript.exe
    On Error Resume Next
    If IsNull(strWSH) Or Not (StrComp(strWSH,"cscript.exe",vbTextCompare) = 0 Or StrComp(strWSH,"wscript.exe",vbTextCompare) = 0) Then
      Exit Sub
    End If
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    If StrComp(fso.GetFileName(WScript.FullName),strWSH,vbTextCompare) <> 0  Then
      Dim str,arg,shell
      Set shell = CreateObject("Shell.Application")
      str = ""
      For Each arg In WScript.Arguments
        str = str & " """ & arg & """"
      Next
      shell.ShellExecute strWSH,"//nologo """ & WScript.ScriptFullName & """ " & str, "", "open", 1
      Set shell = Nothing
      Set fso = Nothing
      WScript.Quit
    Else
      Set fso = Nothing
    End If
  End Sub
]]>
    </script>
  </job>
</package>
复制代码