批量替换word文档中的第一行作为文件的文件名

需求

本次需要将一个文件夹下的所有的word文档中的标题作为word文件的文件名，重命名word文件。

代码

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
    f.Name=GetFileName(f.Path) & ".docx"
  End If 
  If LCase(fso.GetExtensionName(f))="docx" Then
    f.Name=GetFileName(f.Path) & ".docx"
  End If 
  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