Dim FSO, SHELL, Path, File, Output
Set SHELL = CreateObject("Wscript.Shell")
Path = SHELL.CurrentDirectory
Set SHELL = Nothing
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists("Total.doc") Then FSO.DeleteFile "Total.doc"
For Each File In FSO.GetFolder(Path).Files
  If LCase(FSO.GetExtensionName(File)) = "doc" Then Read File.Name
Next
Dim WORD, DOC
Set WORD = CreateObject("Word.Application")
WORD.Visible = False
Set DOC = WORD.Documents.Add()
WORD.Selection.TypeText Output
WORD.Selection.WholeStory
WORD.Selection.Font.Name = "宋体"
WORD.Selection.Font.Size = 12
DOC.SaveAs(Path & "\Total.doc")
DOC.Close
WORD.Quit
Set WORD = Nothing
MsgBox "所有WORD合并完成！合成后的文件为Total.doc", , "ArdentMan友情提示"

Sub Read(File)
 Dim WORD, DOC
 Set WORD = CreateObject("Word.Application")
 Set DOC = WORD.Documents.Open(Path & "\" & File)
 Output = Output & DOC.Range.Text & vbCrLf
 DOC.Close
 WORD.Quit
 Set WORD = Nothing
End Sub
复制代码