如何用vba把word文档的每页单独保存为一个word文档

柔光的暖阳◎ 2023-07-10 08:55 8阅读 0赞

要将word文档的每页单独保存为一个word文档，首先需要能够逐页遍历word文档。

逐页遍历word文档可以使用word的定位功能。

代码如下：

Sub SplitToOnePage()
        Const wdNumberOfPagesInDocument = 4
        Const wdGoToPage = 1
        Const wdGoToAbsolute = 1
        Dim oDoc As Document
        Dim oRng As Range
        Dim oDocTemp As Document
        Set oDoc = Word.ActiveDocument
        Dim sPath As String
        sPath = Word.ActiveDocument.Path
        Dim iPageNo As Long
        '获取总页数
        With oDoc
        iPageNo = .Range.Information(wdNumberOfPagesInDocument)
            For I = 1 To iPageNo
                '定位到页开始
                Set oRng = .GoTo(wdGoToPage, Which:=wdGoToAbsolute, Count:=I)
                oRng.Select
                '定位整个页面区域
                oRng.SetRange oRng.Start, oRng.Bookmarks("\page").End
                oRng.Copy
                Set oDocTemp = Word.Documents.Add
                With oDocTemp.Application.Selection
                    .Paste
                End With
                oDocTemp.SaveAs2 sPath & "\" & I & ".docx"
                oDocTemp.Close
            Next I
        End With
    End Sub

=====================================
    可以保存任何内容
    
    Option Explicit
    
    Sub SplitPagesAsDocuments()
    	Dim oSrcDoc As Document
    	Dim oNewDoc As Document
    	Dim strSrcName As String
    	Dim 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 QQ1722187970()
        Const wdNumberOfPagesInDocument = 4
        Const wdGoToPage = 1
        Const wdGoToAbsolute = 1
        Dim oDoc As Document
        Dim oRng As Range
        Dim oDocTemp As Document
        Set oDoc = Word.ActiveDocument
        Dim sPath As String
        sPath = Word.ActiveDocument.Path
        Dim iPageNo As Long
        '获取总页数
        With oDoc
        iPageNo = .Range.Information(wdNumberOfPagesInDocument)
            For I = 1 To iPageNo
                '定位到页开始
                Set oRng = .GoTo(wdGoToPage, Which:=wdGoToAbsolute, Count:=I)
                oRng.Select
                '定位整个页面区域
                oRng.SetRange oRng.Start, oRng.Bookmarks("\page").End
                oRng.Copy
                Set oDocTemp = Word.Documents.Add
                With oDocTemp.Application.Selection
                    .Paste
                End With
                oDocTemp.SaveAs2 sPath & "\" & I & ".docx"
                oDocTemp.Close
            Next I
        End With
    End Sub

===========================================
    只能保存文字 
    Option Explicit
    
    Sub SaveParagraph()
    	Dim i As Integer
    	Dim 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
    
    End Sub

### [word中怎样把不同颜色的下划线文字变成对应的颜色][word] ###

[word]: https://bbs.csdn.net/topics/392458251?page=1