set fso=createobject("scripting.filesystemobject")
set folder=fso.getfolder(".")
set files=folder.files
for each file in files 
        if lcase(right(file,3))="doc"  then
                a=1
                Set objWord = CreateObject("Word.Application")
                Set objDoc = objWord.Documents.Open(cstr(file))
                wjm=objDoc.Paragraphs(1).Range
                objWord.Quit
        if file.name <> replace(wjm,vbcr,"") & ".doc" then createobject("wscript.shell").run "cmd /c ren " & chr(34) & file.name  & chr(34) & " " & chr(34) & wjm & ".doc"  & chr(34),0
        end if
next
if a=1 then
        msgbox "操作成功!",4096,"提示"
else
        msgbox "对不起，没有在【" & folder & "】下找到WORD文件",4096,"提示"
end if 
复制代码

Dim fso,fc,f,strName
Set fso = CreateObject("scripting.filesystemobject")
Set fc=fso.GetFolder(".").Files
For Each f In fc
  If LCase(fso.GetExtensionName(f))="doc" Then
    strName=GetFileName(f.Path)
  End If 
  f.Name=strName & ".doc"
  Exit For 
Next
Set fso=Nothing 
Function GetFileName(FilePath)
  Dim i,objWord,Doc
  Set objWord=CreateObject("word.application")
  Set Doc=objWord.Documents.Open(FilePath)
  For i=1 To Doc.Paragraphs.Count
    If Replace(Doc.Paragraphs(i).Range," ","")<>vbCr Then 
      GetFileName=Replace(Doc.Paragraphs(i).Range,vbCr,"")
      Exit For
    End If 
  Next
  objWord.Quit
  Set objWord=Nothing 
End Function
复制代码