Word分页程序代码

1. 打开文档。

2. 快捷键Alt + F11打开VBA编辑器，选择菜单“插入->模块”

3. 粘贴代码

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 = 110 ' 修改这里控制每隔几页分割一次

Set fso = CreateObject("Scripting.FileSystemObject")

Set oSrcDoc = ActiveDocument

Set oRange = oSrcDoc.Content

nTotalPages = rmation(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

4. 快捷键F5 运行，直到出现“完成”表示结束。————————————————

打开要处理的WORD文档，然后ALT+F8调出宏处理窗口，新输入宏名称为MyPg。点击右侧的编辑按钮，输入如下内容，完成后键盘F5即可。

但完成后最后2个文件也会会有问题，手动修改一下就行了。

Sub MyPg()

Dim oWord As Word.Application

Dim oDoc As Word.Document

Dim oNewDoc As Word.Document

Dim oRange As Word.Range

Dim lCurrentStart As Long

Dim lCurrentEnd As Long

Dim lDocumentEnd As Long

Dim lOutputCount As Long

lOutputCount = 0

Set oWord = GetObject(, "Word.Application")

Set oDoc = ActiveDocument

oDoc.Select

lCurrentStart = oWord.Selection.Start

lCurrentEnd = lCurrentStart

lDocumentEnd = oWord.Selection.End

oWord.Selection.Collapse wdCollapseStart

Do While (lCurrentEnd < lDocumentEnd)

oWord.Browser.T arget = wdBrowsePage

oWord.Browser.Next

oWord.Browser.Next

oWord.Browser.Next

oWord.Browser.Next

lCurrentEnd = oWord.Selection.End

If (lCurrentStart = lCurrentEnd) Then

lCurrentEnd = lDocumentEnd

End If

Set oRange = oDoc.Range(lCurrentStart, lCurrentEnd)

Set oNewDoc = oWord.Documents.Add

oRange.Copy

oNewDoc.Range(0, 0).Paste

lOutputCount = lOutputCount + 1

oNewDoc.SaveAs FileName:="d:\" & lOutputCount & ".doc"

oNewDoc.Close

lCurrentStart = lCurrentEnd

Loop

End Sub