求修改代码实现以新文档首行命名

天使Aster

求各位大神帮忙看下这个代码，我运行后在新文档最后总是出现一张空白页，而且新文档想实现以新文档首行标题命名，拜托各位大神了，谢谢~{:soso_e183:}


Sub SplitEveryFivePagesAsDocuments()
Dim oSrcDoc As Document, oNewDoc As Document
Dim strSrcName As String, strNewName As String
Dim oRange As Range
Dim nIndex As Integer, nSubIndex As Integer, nTotalPages As Integer, nBound As Integer
Dim fso As Object
Const nSteps = 1
Set fso = CreateObject("Scripting.FileSystemObject")
Set oSrcDoc = ActiveDocument
Set oRange = oSrcDoc.Content
nTotalPages = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
oRange.Collapse wdCollapseStart
oRange.Select
For nIndex = 1 To nTotalPages Step nSteps
    Set oNewDoc = Documents.Add
    If nIndex + nSteps > nTotalPages Then
        nBound = nTotalPages
    Else
        nBound = nIndex + nSteps - 1
    End If
    For nSubIndex = nIndex To nBound
        oSrcDoc.Activate
        oSrcDoc.Bookmarks("\page").Range.Copy
        oSrcDoc.Windows(1).Activate
        Application.Browser.Target = wdBrowsePage
        Application.Browser.Next
        oNewDoc.Activate
        oNewDoc.Windows(1).Selection.Paste
    Next nSubIndex
    strSrcName = oSrcDoc.FullName
    strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
                 fso.GetBaseName(strSrcName) & "_" & (nIndex \ nSteps + 1) & "." & fso.GetExtensionName(strSrcName))
    oNewDoc.SaveAs strNewName
    oNewDoc.Close False
Next nIndex
Set oNewDoc = Nothing
Set oRange = Nothing
Set oSrcDoc = Nothing
Set fso = Nothing
MsgBox "It's OK"

End Sub