Word根据文件第一行重新命名

遇到一个场景，有大量word文件（根据邮件合并来的，邮件合并后拆分了单个文件）需要重新命名，命名规则是从word文档中第一行提取。

Sub batchRename()

'
' 将Word文件重新命名
' 可以使用的是Word的另存为功能或者重命名功能
'


Application.ScreenUpdating = False
'Application.DisplayAlerts = wdAlertsNone

'关掉部分错误提示

Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "请选择文件夹"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then
        Exit Sub
    End If
    sItem = .SelectedItems(1)
End With

getfolder = sItem
Set fldr = Nothing

'上面是选择文件夹

Files = Dir(getfolder & "\*.doc*")

On Error Resume Next

While Files <> ""
    ChangeFileOpenDirectory getfolder
    Documents.Open FileName:=Files, _
        ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
        PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
        WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
        wdOpenFormatAuto, XMLTransform:=""
    '打开文件
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Name:=0
    Selection.Extend
    Selection.EndKey Unit:=wdLine
    Selection.EscapeKey
		'选择第一行，获取第一行内容
    newfilename = Replace(Selection.Range, vbCrLf, "")
    newfilename = Replace(newfilename, vbLf, "")
    newfilename = Replace(newfilename, Chr(11), "") '<<< remove vertical tab
    newfilename = Trim(Replace(newfilename, vbCr, ""))
		'删除第一行中换行符、空格等
    'ActiveDocument.SaveAs2 FileName:=getfolder & "\" & newfilename & ".docx"
   'ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        getfolder & "\" & newfilename & ".pdf", _
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    '将打开的文件导出为PDF文件
    ActiveDocument.Close (0)
    Name getfolder & "\" & Files As getfolder & "\" & newfilename & ".docx"
    Files = Dir
Wend
'打开所有文件，另存为PDF文件

Application.ScreenUpdating = True
Application.DisplayAlerts = wdAlertsAll

'打开错误提示

End Sub