求帮忙修改批量提取某文件夹下的所有word文件的标题作为文件名的宏

wh1813

宏如下：

Sub SaveDoc()

   Dim P_Doc As Document, P_Path, str_Path As String, myRange As Range

   With Application.FileDialog(msoFileDialogFilePicker)

      .Title = "请选择被另存的Word文件"

      .AllowMultiSelect = True

      .Filters.Clear

      .Filters.Add "Word 文档", "*.doc"

          If .Show = -1 Then

             str_Path = CurDir & "\"

             For Each P_Path In .SelectedItems

                Set P_Doc = Documents.Open(FileName:=P_Path)

                Set myRange = P_Doc.Paragraphs(1).Range

                myRange.MoveEnd wdCharacter, -1

                P_Doc.SaveAs str_Path & myRange.Text

                P_Doc.Close

             Next

          End If

   End With

End Sub

需要修改两个地方：、

1、不要另存为，直接修改保存，这样就不用重新生成文件了

2、遇到第一行包含特殊字符，删除特殊字符后，继续生成文件名

哪位大神有空，帮忙给修改下！