|
请参： 注意事项：主文档中的光标应处于正文部分，不要处于页眉页脚内；生成的新文档有可能在打开时处于普通视图中，请切换到页面视图中。 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, i As Integer
On Error Resume Next
Application.ScreenUpdating = False
With Selection
PageCount = .Information(wdNumberOfPagesInDocument)
.HomeKey unit:=wdStory
For i = 1 To PageCount
StartRange = .Start
Fn = i & "_" & ActiveDocument.Name
Set MyHeader = .Sections(1).Headers(wdHeaderFooterPrimary).Range
MyHeader.Copy
Set MyFooter = .Sections(1).Footers(wdHeaderFooterPrimary).Range
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
MyFooter.Copy
Application.Run "GoToHeaderFooter"
.Paste
.Paragraphs(.Paragraphs.Count).Range.Delete
End With
.ActiveWindow.View.SeekView = wdSeekMainDocument
End With
ThisDocument.Activate
If i = PageCount Then
EndRange = ActiveDocument.Content.End
Else
EndRange = .GoToNext(wdGoToPage).Start
End If
Set MyRange = ActiveDocument.Range(StartRange, EndRange)
MyRange.Copy
With Application.Windows(MyDoc).Selection
.Paste
MyDoc.Content.Find.Execute Findtext:="^b", Replacewith:="^p", Replace:=wdReplaceAll
.Paragraphs(.Paragraphs.Count).Range.Delete
MyDoc.SaveAs FileName:=Fn
MyDoc.Close
End With
Next
End With
Application.ScreenUpdating = True
End Sub
| 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2004-11-12 11:59
楼主