Sub mySaveAs()
'
Dim i As Long, st As Single, mypath As String, fs As FileSearch
Dim myDoc As Document, n As Integer
Dim strpara1 As String, strpara2 As String, docname As String, a
On Error GoTo hd
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "请选定任一文件，确定后将重命名全部WORD文档"
If .Show <> -1 Then Exit Sub
st = Timer
mypath = .InitialFileName
End With
Application.ScreenUpdating = False
If Dir(mypath & "另存为", vbDirectory) = "" Then MkDir mypath & "另存为" '另存为文档的保存位置
Set fs = Application.FileSearch
With fs
.NewSearch
.LookIn = mypath
.FileType = msoFileTypeWordDocuments
If .Execute(msoSortByFileName) > 0 Then
For i = 1 To .FoundFiles.Count
If InStr(fs.FoundFiles(i), "~$") = 0 Then
Set myDoc = Documents.Open(.FoundFiles(i), Visible:=False)
With myDoc
strpara1 = Replace(.Paragraphs(1).Range.Text, Chr(13), "")
strpara1 = Left(strpara1, 10)
strpara2 = Replace(.Paragraphs(2).Range.Text, Chr(13), "")
If Len(strpara1) < 2 Or Len(strpara2) < 2 Then GoTo hd
docname = strpara1 & "_" & strpara2
docname = CleanString(docname)
For Each a In Array("\", "/", ":", "*", "?", """ ", "<", " >", "|")
docname = Replace(docname, a, "")
Next
.SaveAs mypath & "另存为\" & docname & ".doc"
n = n + 1
.Close
End With
End If
Next
End If
End With
MsgBox "共处理了" & fs.FoundFiles.Count & "个文档，保存于目标文件夹的名称为“另存为”的下一级文件夹中。" _
& vbCrLf & "处理时间：" & Format(Timer - st, "0") & "秒。"
Application.ScreenUpdating = True
Exit Sub
hd:
MsgBox "运行出现意外，程序终止！" & vbCrLf & "已处理文档数：" & n _
& vbCrLf & "出错文档：" & vbCrLf & fs.FoundFiles(i)
If Not myDoc Is Nothing Then myDoc.Close
End Sub