关于word每页存为一个文档的问题

cnmyxk

在Office精英俱乐部里有一个分页保存的宏代码，很是漂亮：可列为精华：

Sub 分页保存()
myPath = "D:\temp\"
Selection.HomeKey Unit:=wdStory
Set myRange = Selection.Range
curpage = 0
Application.ScreenUpdating = False
Do
   prepage = curpage
   pagenum = pagenum + 1
   Set myRange = myRange.GoToNext(What:=wdGoToPage)
   curpage = myRange.Start
   endpage = myRange.Previous.Start
   If curpage = prepage Then _
      endpage = ActiveDocument.Content.End
   ActiveDocument.Range(prepage, endpage).Copy
   With Documents.Add
      .Content.Paste
      .SaveAs myPath & "Page" & pagenum & ".doc"
      .Close
   End With
   If curpage = prepage Then Exit Do
Loop
Application.ScreenUpdating = True
End Sub

但有这样一个问题，我这个文件怎么不能分开，请教高手，怎么不行？

S9vV5zqw.rar (14.58 KB, 下载次数: 87)

2004-7-22 08:10 上传

点击文件名下载附件
关于word每页存为一个文档的问题

下面是本论坛守柔兄的代码，粘贴于活动文档中（即你的主文档中）的“THISDOCUMENT”模块中：

Sub SaveAsPage()
Dim PageCount As Integer, StartRange As Long, EndRange As Long, MyRange As Range, Fn As String, MyDoc As Document
On Error Resume Next
PageCount = Selection.Information(wdNumberOfPagesInDocument)
Range(0, 0).Select '将光标移至文档起点
For i = 1 To PageCount '设置循环次数
    StartRange = Selection.Start '取得该页的第一个字符位置
    Selection.EndKey Unit:=wdLine '将光标移动到该页首行的最后位置
    Fn = i & ActiveDocument.Name '-1的目的是防止该页首行含有段落标记,导致出错.
        If i = PageCount Then '如果循环到达最后一页
        EndRange = ActiveDocument.Content.End '将文档最后位置赋值于EndRange
        Else
        Selection.GoToNext (wdGoToPage) '否则,将下一页的起始位置赋值于EndRange(等同于本页的最后位置)
        EndRange = Selection.Start
        End If
    Set MyRange = Range(StartRange, EndRange) '将本页中的内容进行复制
    MyRange.Copy
    Set MyDoc = Documents.Add '新建一空白文档
    MyDoc.Range(0, 0).Paste '在文档开始处粘贴
    MyDoc.SaveAs FileName:=Fn '保存文档名
    MyDoc.Close '关闭文档
Next
End Sub

[此贴子已经被konggs于2008-8-23 10:26:50编辑过]

守柔

本论坛中也有呀,也许更管用!

http://club.excelhome.net/viewthread.php?tid=52690

你将其中的一行代码改为:

Fn = i & ActiveDocument.Name即可.

另外你的文档可不敢恭维哟!

cxffxc

为什么要把每页都存为一篇独立的文档呢？

cnmyxk

0.先谢谢守柔兄，竟然忘了这事，真不好意思。加个0吧。

1.这个文档是由邮件合并生成。

2.页大小设置以及位置现在都能正常运行，正常打印。原先我都设置成信封大小，但打印机不行，打不出来。就改成A4纸，用控制打印位置的方式来进行打印。

3.用文本框是因为可以用他来方便的调成不同大小的信封。

字体当然是别人的要求了。

4.我用守柔兄的代码生成，结果每个省的后面都带着个尾巴。请守柔兄给改原文档吧。先谢谢，哈哈，我这是小人做人，给人以压迫感。

vOUisKnJ.rar (7.88 KB, 下载次数: 69)

2004-7-22 12:53 上传

点击文件名下载附件

[此贴子已经被作者于2004-7-22 12:58:28编辑过]

cnmyxk

以下是引用cxffxc在2004-7-22 9:20:00的发言： 为什么要把每页都存为一篇独立的文档呢？

别人要求，没办法了。

我是一块鹅卵石，都没角了。

领导让干哈，咱就干哈，明知错了咱也干，何况这也没错，只是费事废事而已。

守柔

你的信封是邮件合并做的文本框格式的，对于编程来说，有些地方说不好。

就好象是每页分别存档吧与你的主控文档有关系，你应该在主控文档上想想办法我这地方不好改。

方便的话用表格做成与信封差不多的再邮件合并吧。

然后再运行此代码。

[ 本帖最后由 守柔 于 2009-5-25 05:58 编辑 ]

cnmyxk

邮件合并生成合并文档是用分节符分在下一页控制分页的，分页符在页眉内。

cnmyxk

不防灌下水。

守柔

百计无由！！（WORD中的邮件合并功能，自动在合并的文档中插入分节符，所以只能一个一个删除了），请在邮件合并到文档后的文件中，运行以下代码：

Sub SaveAsPage()
Dim PageCount As Integer, StartRange As Long, EndRange As Long, MyRange As Range, Fn As String, MyDoc As Document
On Error Resume Next
PageCount = Selection.Information(wdNumberOfPagesInDocument)
Range(0, 0).Select '½«¹â±êÒÆÖÁÎĵµÆðµã
For i = 1 To PageCount 'ÉèÖÃÑ­»·´ÎÊý
    StartRange = Selection.Start 'È¡µÃ¸ÃÒ³µÄµÚÒ»¸ö×Ö·ûλÖÃ
    Selection.EndKey Unit:=wdLine '½«¹â±êÒƶ¯µ½¸ÃÒ³Ê×ÐеÄ×îºóλÖÃ
    Fn = i & ActiveDocument.Name '-1µÄÄ¿µÄÊÇ·ÀÖ¹¸ÃÒ³Ê×Ðк¬ÓжÎÂä±ê¼Ç,µ¼Ö³ö´í.
        If i = PageCount Then 'Èç¹ûÑ­»·µ½´ï×îºóÒ»Ò³
        EndRange = ActiveDocument.Content.End '½«Îĵµ×îºóλÖø³ÖµÓÚEndRange
        Else
        Selection.GoToNext (wdGoToPage) '·ñÔò,½«ÏÂÒ»Ò³µÄÆðʼλÖø³ÖµÓÚEndRange(µÈͬÓÚ±¾Ò³µÄ×îºóλÖÃ)
        EndRange = Selection.Start
        End If
    Set MyRange = Range(StartRange, EndRange) '½«±¾Ò³ÖеÄÄÚÈݽøÐи´ÖÆ
    MyRange.Copy
    Set MyDoc = Documents.Add 'н¨Ò»¿Õ°×Îĵµ
    MyDoc.Range(0, 0).Paste 'ÔÚÎĵµ¿ªÊ¼´¦Õ³Ìù
    With MyDoc.Content.Find
        .Text = "^b"
        .Replacement.Text = ""
        .Forward = True
        .Execute Replace:=wdReplaceAll
    End With
    With MyDoc.PageSetup
        .TopMargin = CentimetersToPoints(5.4)
        .BottomMargin = CentimetersToPoints(5.4)
        .LeftMargin = CentimetersToPoints(7.9)
        .RightMargin = CentimetersToPoints(1.2)
        .PageWidth = CentimetersToPoints(29.7)
        .PageHeight = CentimetersToPoints(21)
    End With
    MyDoc.SaveAs FileName:=Fn '±£´æÎĵµÃû
    MyDoc.Close '¹Ø±ÕÎĵµ
Next
End Sub
受粘贴中文字体影响，以上乱码与上述代码中的一致，不再修改。

[此贴子已经被konggs于2008-8-23 10:26:07编辑过]

cnmyxk

不错，本帖结帖。