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
