把WORD文档每一页拆分成单独的文件

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

二、指定页拆分

不过那个是按单页拆分的。如果想按照指定页数拆分，请使用下面的代码，其它步骤和原来那个方案相同。

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

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

第二种方法

Option Explicit

 Sub SaveParagraph()

 Dim i As Integer, PageNo As Integer

 Dim aDoc As Document

 Dim myDoc As Document

 Dim sPage As String

Set myDoc = ThisDocument

'文 档 视 图 设 定 为 页 面 方 式

ActiveWindow.View.Type = wdPageView

 myDoc.Repaginate

 '获 得 文 档 页 数 并 赋 值 给 变 量 PageNo

 PageNo = myDoc.BuiltInDocumentProperties(wdPropertyPages)

For i = 1 To PageNo

 myDoc.Activate

 ' 光 标 移 动 到 文 档 某一 页 的 开 始

Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=i

 ' 全 选 文 档某一 页 的 所 有 内 容

Selection.EndKey Unit:=wdStory, Extend:=wdExtend

 sPage = Selection.Text

 '保存到一个文件中

Set aDoc = Documents.Add

 aDoc.Content.Text = sPage

 aDoc.SaveAs FileName:="c:\" & CInt(i) & ".doc"

 aDoc.Close

 Next

其它方法

 

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

Sub SaveAsFileByPage()

 

Dim objShell As Object, objFolder As Object, strNameLenth As Integer

 

Dim mySelection As Selection, myFolder As String, myArray() As String

 

Dim ThisDoc As Document, myDoc As Document, strName As String, N As Integer

 

Dim myRange As Range, PageString As String, pgOrientation As WdOrientation

 

Dim sinLeft As Single, sinRight As Single, sinTop As Single, sinBottom As Single

 

Dim ErrChar() As Variant, oChar As Variant, sinStart As Single, sinEnd As Single

 

Const myMsgTitle As String = "豆芽网"

 

Dim vbYN As VbMsgBoxResult

 

sinStart = Timer

 

On Error GoTo ErrHandle

 

'get path startpoint

Set objShell = CreateObject("Shell.Application")

 

Set objFolder = objShell.BrowseForFolder(0, "请选择一个文件夹", 0, 0)

 

If objFolder Is Nothing Then Exit Sub

 

myFolder = objFolder.Self.Path & "\"

 

Set objFolder = Nothing: Set objShell = Nothing

 

'get path endpoint

Set ThisDoc = ActiveDocument

 

Set mySelection = ThisDoc.ActiveWindow.Selection

 

'===========

ErrChar = Array("\", "/", ":", "*", "?", """", "<", ">", "|")

 

For N = 0 To 31

 

ReDim Preserve ErrChar(UBound(ErrChar) + 1)

 

ErrChar(UBound(ErrChar)) = Chr(N)

 

Next

'=============== the above code fillin Array ErrChar with space

 

strNameLenth = Val(VBA.InputBox(prompt:="请输入您需要设置的文件名长度,0或者取消将自动命名!", Title:=myMsgTitle, Default:=10))

 

If strNameLenth > 255 Then strNameLenth = 0

 

'====the above to get filename limits

vbYN = MsgBox("是否需要处理页尾的分隔符(分页符/分节符)?它可能会影响文档结构.", vbYesNo + vbInformation + vbDefaultButton2, myMsgTitle)

 

Application.ScreenUpdating = False

 

'=============================

For N = 1 To mySelection.Information(wdNumberOfPagesInDocument)

 

'------- the above is to go through all pages

mySelection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=N

 

Set myRange = ThisDoc.Bookmarks("\PAGE").Range

'--------------

 

If vbYN = vbYes And VBA.Asc(myRange.Characters.Last.Text) = 12 Then myRange.SetRange myRange.Start, myRange.End - 1

'------------------------------- the above is to treat division marker

myArray = VBA.Split(myRange.Text, Chr(13))

 

PageString = VBA.Join(myArray, "")

'--------to use space marker replace paragraph marker

 

With myRange.Sections(1).PageSetup

 

sinLeft = .LeftMargin

 

sinRight = .RightMargin

 

sinTop = .TopMargin

 

sinBottom = .BottomMargin

 

pgOrientation = .Orientation

 

End With

'----------the above is to redefine page layout

 

For Each oChar In ErrChar

 

PageString = VBA.Replace(PageString, oChar, "")

 

Next

'------------- the above is to replace errchar in pagestring with space marker

 

If strNameLenth = 0 Then

 

strName = ThisDoc.Name

 

strName = VBA.Replace(LCase(strName), ".doc", "")

'the above is to replace filename extension with space

 

strName = strName & "_" & N

 

Else

 

strName = VBA.Left(PageString, strNameLenth)

 

End If

'the above is a filename pretreatment. use  block-if-code to response inputbox decision at front part.

 

strName = strName & ".doc"

'---- the above is to build up filename to saveas

'=== in face from Set myRange = ThisDoc.Bookmarks("\PAGE").Range to here is all pretreatment

 

myRange.Copy

 

'-------------

Set myDoc = Documents.Add(Visible:=False)

 

With myDoc

 

.Content.Paste

 

.Content.Paragraphs.Last.Range.Delete

 

'-------------

 

 

With .PageSetup

 

.Orientation = pgOrientation

 

.LeftMargin = sinLeft

 

.RightMargin = sinRight

 

.TopMargin = sinTop

 

.BottomMargin = sinBottom

 

End With

'----------------------

 

If VBA.Dir(myFolder & strName, vbDirectory) <> "" Then strName = "Page_" & N & ".doc"

'-------------- the above is to avoid filename exist

 

.SaveAs myFolder & strName

 

.Close

 

End With

'--------------

 

Next

' this next is to go through all paragraphs

 

ThisDoc.Characters(1).Copy

 

Application.ScreenUpdating = True

 

sinEnd = Timer

 

'If MsgBox("分页保存结束,用时:" & sinEnd - sinStart & "秒,是否打开指定文件夹查看分页保存后的文档情况?", vbYesNo, myMsgTitle) = vbYes Then ThisDoc.FollowHyperlink myFolder

 

Exit Sub

 

ErrHandle:

 

MsgBox "错误号:" & Err.Number & vbLf & "出错原因:" & Err.Description, myMsgTitle

 

Err.Clear

 

Application.ScreenUpdating = True

 

End Sub