Word文档自动用标题作为文件名保存文件

@TOC假定第三行和第一行是需要存档的标题，首先把第三行的文字和第一行的合并

ActiveDocument.Bookmarks("\page").Range.Paragraphs.Item(4).Range.Select
Selection.HomeKey
Selection.EndKey unit:=wdLine, Extend:=wdExtend
Selection.Cut
'移动光标到第1行、最后一个字符，无格式粘贴
Selection.HomeKey unit:=wdStory
Selection.EndKey unit:=wdLine
Selection.PasteAndFormat (wdFormatPlainText)
'移动光标到第1行，选择整行作为标题
Selection.HomeKey
Selection.EndKey unit:=wdLine, Extend:=wdExtend
Selection.Copy
Myfilename = Trim(Selection.Text) & ".docx"

@TOC再清除word的特定字符，这个花了很长时间没找到可用的函数，只好用正则

'清除特殊字符
Dim str$, s$, mh
str = Myfilename
With CreateObject("vbscript.regexp")
    .Pattern = "[\u3000-\u303F]|[\u4e00-\u9fa5]|[A-Za-z0-9]|[\[]|[\]]|[\(]|[\)]|[\.]"
    .Global = True
    If .test(str) Then
        For Each mh In .Execute(str)
            s = s & mh.Value
        Next
        'MsgBox s
    End If
End With
Myfilename = s

@TOC最后设置一个目录存档

'存档
ChangeFileOpenDirectory "D:\mydoc\"
ActiveDocument.SaveAs2 FileName:= _
        Myfilename, FileFormat:= _
        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False, CompatibilityMode:=wdCurrent