word 文档分割程序

1、按页分割
Option Explicit
Sub SplitPagesAsDocuments()

Dim oSrcDoc As Document, oNewDoc As Document
Dim strSrcName As String, strNewName As String
Dim oRange As Range
Dim nIndex As Integer
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set oSrcDoc = ActiveDocument
Set oRange = oSrcDoc.Content
oRange.Collapse wdCollapseStart
oRange.Select
For nIndex = 1 To ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
oSrcDoc.Bookmarks("\page").Range.Copy
oSrcDoc.Windows(1).Activate
Application.Browser.Target = wdBrowsePage
Application.Browser.Next
strSrcName = oSrcDoc.FullName
strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
fso.GetBaseName(strSrcName) & "_" & nIndex & "." & fso.GetExtensionName(strSrcName))
Set oNewDoc = Documents.Add
Selection.Paste
oNewDoc.SaveAs strNewName
oNewDoc.Close False
Next
Set oNewDoc = Nothing
Set oRange = Nothing
Set oSrcDoc = Nothing
Set fso = Nothing
MsgBox "结束！"
End Sub
2、设置隔几页分割
Option Explicit
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 "结束！"
End Sub
3、查找分割
Option Explicit

Const Token1 = "Point Name"
Const Token2 = "- END -"

 

Sub SplitDocumentByToken()

    Dim oNewDoc As Document
    Dim strSrcName As String, strNewName As String
    Dim nStart As Long, nEnd As Long, nIndex As Integer
    Dim fContinue As Boolean
    Dim fso As Object
   
    Set fso = CreateObject("Scripting.FileSystemObject")

    strSrcName = ActiveDocument.FullName
   
    nIndex = 1
    fContinue = True
    Selection.StartOf WdUnits.wdStory

    Do While fContinue
        nStart = Selection.Start
     
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = Token1
            .Replacement.Text = ""
            .Forward = True
            .Wrap = WdFindWrap.wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = True
        End With
        If Selection.Find.Execute Then
    
            nEnd = Selection.End
        Else
            nEnd = ActiveDocument.Content.End
            fContinue = False
        End If
        ActiveDocument.Range(nStart, nEnd).Copy
        strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
                     fso.GetBaseName(strSrcName) & "_" & nIndex & "." & fso.GetExtensionName(strSrcName))
        Set oNewDoc = Documents.Add
        Selection.Paste
        oNewDoc.SaveAs strNewName
        oNewDoc.Close False
        nIndex = nIndex + 1
        Selection.Collapse WdCollapseDirection.wdCollapseEnd
    Loop

    Set oNewDoc = Nothing
    Set fso = Nothing

    MsgBox "结束！"

End Sub