'http://social.msdn.microsoft.com/Forums/en-US/isvvba/thread/4fbbd7e1-7ff1-4c97-a53b-eeef490b5e5c

docsfolder = "C:\Users\Administrator\Desktop\docs"

Set fso = CreateObject("Scripting.FileSystemObject")
Set word = CreateObject("Word.Application")
  word.Visible = True
FindDocs docsfolder
word.Quit

Sub OpenOneDoc(sExactPath)
  With word
    .Documents.Open sExactPath, False, False
    .Application.CommandBars.FindControl(1, 6382).Execute
    ' wdDoNotSaveChanges = 0, wdPromptToSaveChanges = -2, wdSaveChanges = -1
    .ActiveDocument.Close -1
  End With
End Sub

Sub FindDocs(folderspec)  
  Dim f, f1, fc, s
  If Not fso.FolderExists(folderspec) Then
    MsgBox "文件夹不存在"  
    WScript.Quit
  else  
    Set f = fso.GetFolder(folderspec)
    Set fc = f.files
    For Each f1 in fc
      If LCase(Right(f1.Path, 4)) = ".doc" Or LCase(Right(f1.Path, 5)) = ".docx" Then
        OpenOneDoc f1.Path
      End If
    Next
    Set ff=f.SubFolders  
    For Each f2 in ff  
      FindDocs f2.Path
    Next
  End If
End Sub
复制代码