MS Word VBA：使用标题保存文档

Question

我一直在尝试找出一种方法，在执行邮件合并之后，将文档分成单独的文档，并以特定的项目（最好是标题的第一行）命名。 我只能找到拆分文档的方法，但无法弄清楚如何命名它。 非常感谢您提供有关如何编写VBA代码以将文档另存为标题的任何帮助。

Answer 1

由于您已经分开了文档，因此下面的代码可能会使用第一句话为其命名。

Private Function DocName(Doc As Document) As String
    ' 23 Aug 2017

    Const Illegals As String = "\:/;?*|>"""
    Static FaultCounter As Integer
    Dim Fun As String
    Dim Title As String
    Dim Ch As String
    Dim i As Integer

    Title = Trim(Doc.Sentences(1))
    For i = 1 To Len(Title)
        Ch = Mid(Title, i, 1)
        If (Asc(Ch) > 31) And (Asc(Ch) < 129) Then
            If InStr(Illegals, Ch) = 0 Then Fun = Fun & Ch
        End If
    Next i

    If Len(Fun) = 0 Then
        FaultCounter = FaultCounter + 1
        Fun = Format(FaultCounter, """Default File Name (""0"")""")
    End If

    DocName = Fun
End Function

保存文件之前，您可能需要检查重复项。 为此，请使用Dir（）函数，并使用上面包含的系统为第一个句子可能为空的文件命名，以重复的名称添加一个数字。

您可能还需要检查文件名中不允许使用的字符。 我只是排除了所有低于ASCII（32）和高于ASCII（128）的东西，然后Windows不喜欢的那些已知东西。 您可能需要进一步修改该范围。

要调用上述函数，请使用如下代码：

Private Sub GetName()
    Debug.Print DocName(ActiveDocument)
End Sub

Answer 2

到目前为止，这是我所拥有的代码，我可以从一个非常有用的网站上找到它，但是该代码另存为“ report”一词，在我试图找出它时将其设置为现在，并且然后是文件编号。

Option Explicit

Sub splitter()

' splitter Macro

' Macro created by Doug Robbins to save each letter created by a mailmergeas 
a separate file.
Application.ScreenUpdating = False
Dim Program As String
Dim DocName As String
Dim Letters As Integer, Counter As Integer

Letters = ActiveDocument.Sections.Count
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
'program = ActiveDocument.MailMerge.DataSource.DataFields("Program_Outcomes_PlanReport_Name").Value
DocName = "Reports" & LTrim$(Str$(Counter))  'Generic name of document
ActiveDocument.Sections.First.Range.Cut
Documents.Add
Selection.Paste
ActiveDocument.Sections(2).PageSetup.SectionStart = wdSectionContinuous


ActiveDocument.SaveAs filename:="E:\assessment rubrics\Templates" & "\" & DocName, FileFormat:=wdFormatDocument, LockComments:=False, Password:="", 
AddToRecentFiles:=False, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False,         SaveAsAOCELetter:=False
ActiveWindow.Close
Counter = Counter + 1
Wend

Application.ScreenUpdating = True

End Sub