分页保存-保留格式设置的代码(VBA)

Sub SaveAsPage()
Dim PageCount As Integer, StartRange As Long, EndRange As Long, MyRange As
Range
Dim Fn As String, MyDoc As Document, MyHeader As Range, MyFooter As Range
On Error Resume Next
With Selection
PageCount = .Information(wdNumberOfPagesInDocument)
.HomeKey unit:=wdStory
For i = 1 To PageCount
StartRange = .Start
Set MyHeader = .Sections(1).Headers(wdHeaderFooterPrimary).Range
MsgBox MyHeader
MyHeader.Copy
Set MyFooter = .Sections(1).Footers(wdHeaderFooterPrimary).Range
MsgBox MyFooter
Set MyDoc = Documents.Add
'原现有光标所在页的页面设置赋值给新文档
With
Application.Windows(ThisDocument.Name).Selection.Sections(1).PageSetup
ActiveDocument.Sections(1).PageSetup.TopMargin = .TopMargin
ActiveDocument.Sections(1).PageSetup.BottomMargin
= .BottomMargin
ActiveDocument.Sections(1).PageSetup.LeftMargin = .LeftMargin
ActiveDocument.Sections(1).PageSetup.RightMargin
= .RightMargin
ActiveDocument.Sections(1).PageSetup.Orientation = .Orientation
End With
With ActiveDocument '打开页眉页脚
.ActiveWindow.View.SeekView = wdSeekCurrentPageHeader
With Application.Windows(MyDoc).Selection
.Paste '粘贴其中内容并删除最后一个段落标记
.Paragraphs(.Paragraphs.Count).Range.Delete
End With '关闭页眉页脚
.ActiveWindow.View.SeekView = wdSeekMainDocument
.ActiveWindow.View.Type = wdPrintView
End With
ThisDocument.Activate
Fn = i & ActiveDocument.Name
If i = PageCount Then    '如果循环到达最后一页
EndRange = ActiveDocument.Content.End  '将文档最后位置赋值于
EndRange
Else
EndRange = .GoToNext(wdGoToPage).Start    '否则,将下一页的起
始位置赋值于 EndRange(等同于本页的最后位置)
End If
Set MyRange = ActiveDocument.Range(StartRange, EndRange)    '将
本页中的内容进行复制
MyRange.Copy
With Application.Windows(MyDoc).Selection
.Paste
.Paragraphs(.Paragraphs.Count).Range.Delete
.Find.Execute  findtext:="^m",  Replacewith:="",
Replace:=wdReplaceAll
MyDoc.SaveAs FileName:=Fn    '保存文档名
MyDoc.Close    '关闭文档
End With
Next
End With
End Sub
'----------------------