[求助]【急】用宏按页拆分出错

chianson

我用下面的语句进行按页拆分WORD文档，执行之后生成很多WORD文档，并且只拆分了一个，其他文档都是空的。

麻烦看看是不是代码错了。谢谢。

代码：

  Sub   SplitDocument()  
  '  
  '   将文档按页拆分为多个文档  
  '   第一页保留在原文档中，以后的页保存在新的文档中  
  '   需要指定的参数：savefilename   新文档的保存路径和文件名前缀  
  '                                   pagecount         文档的总页数  
  '  
          Dim   SaveFileName$  
          SaveFileName   =   "c:\zj"     '设置文件保存的路径和文件名，这里为c:\zj*.doc,*为页码序号  
           
          Dim   PageCount&,   i&  
          PageCount   =   9               '输入总页数,这里假设为2页  
           
          For   i   =   2   To   PageCount  
                  Selection.GoTo   What:=wdGoToPage,   Which:=wdGoToNext,   Name:="2"   '定位页（光标会自动停在页的第一行）
                  Selection.Find.ClearFormatting  
                  Selection.EndKey   Unit:=wdStory,   Extend:=wdExtend    '全选文档某一页的所有内容
                  Selection.Cut  
                  Documents.Add   DocumentType:=wdNewBlankDocument  
                  Selection.PasteAndFormat   (wdPasteDefault)  
                  '如果只新建不保存，就删除此句  
                  ActiveDocument.SaveAs   FileName:=SaveFileName   &   i   &   ".doc",   FileFormat:=   _  
                          wdFormatDocument,   LockComments:=False,   Password:="",   AddToRecentFiles:=   _  
                          True,   WritePassword:="",   ReadOnlyRecommended:=False,   EmbedTrueTypeFonts:=   _  
                          False,   SaveNativePictureFormat:=False,   SaveFormsData:=False,   _  
                          SaveAsAOCELetter:=False  
          Next  
  End   Sub  

c81

没有错吧，请注意设置pagecount数和你文档实际页数相等试试。

chianson

QUOTE:

以下是引用c81在2007-1-23 14:07:56的发言：
没有错吧，请注意设置pagecount数和你文档实际页数相等试试。

试过了，还是一样，我用的WORD2003。

这对版本有没有要求啊。

你能不能试一下。

守柔

上述代码漏洞很多，请楼主详细说明你的意图。

chianson

QUOTE:

以下是引用守柔在2007-1-23 16:17:16的发言：
上述代码漏洞很多，请楼主详细说明你的意图。

谢谢守柔。

我结合你之前的程序，修改了一下，终于可以完成我的需求——按页拆分WORD文档。

麻烦你帮忙看一下还有没有什么需要改正的（呵呵，其实很多是你的程序）。谢谢。

Sub SaveAsPage()
Dim PageCount As Integer, StartRange As Long, EndRange As Long, MyRange As Range, Fn As String, MyDoc As Document

Dim SaveFileName$
          SaveFileName = "c:\zj"         '设置文件保存的路径和文件名，这里为c:\zj*.doc,*为页码序号

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 = Range(StartRange, Selection.End - 1) '-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 '在文档开始处粘贴

  ActiveDocument.SaveAs FileName:=SaveFileName & i & ".doc", FileFormat:= _
                          wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
                          True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
                          False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
                          SaveAsAOCELetter:=False
 
  MyDoc.Close '关闭文档
  Next
End Sub

守柔

这是很久以前的贴子了，我修正一下：

Sub SaveAsPage()
    Dim PageCount As Integer, StartRange As Long, EndRange As Long, MyRange As Range, Fn As String, MyDoc As Document
    Dim SaveFileName$
    SaveFileName = "c:\zj"         '设置文件保存的路径和文件名，这里为c:\zj*.doc,*为页码序号
    On Error Resume Next
    PageCount = Selection.Information(wdNumberOfPagesInDocument)
   ThisDocument.Range(0, 0).Select    '将光标移至文档起点
    For i = 1 To PageCount    '设置循环次数
        StartRange = Selection.Start    '取得该页的第一个字符位置
        Selection.EndKey Unit:=wdLine    '将光标移动到该页首行的最后位置
        Fn = ThisDocument.Range(StartRange, Selection.End - 1)    '-1的目的是防止该页首行含有段落标记,导致出错.
        If i = PageCount Then    '如果循环到达最后一页
            EndRange = ThisDocument.Content.End    '将文档最后位置赋值于EndRange
        Else
            Selection.GoToNext (wdGoToPage)    '否则,将下一页的起始位置赋值于EndRange(等同于本页的最后位置)
            EndRange = Selection.Start
        End If
        Set MyRange = ThisDocument.Range(StartRange, EndRange)    '将本页中的内容进行复制
        MyRange.Copy
        Set MyDoc = Documents.Add    '新建一空白文档
        MyDoc.Range(0, 0).Paste    '在文档开始处粘贴
        ActiveDocument.SaveAs FileName:=SaveFileName & i & ".doc", FileFormat:= _
                              wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
                              True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
                              False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
                              SaveAsAOCELetter:=False
        MyDoc.Close    '关闭文档
    Next
End Sub
'----------------------

chianson

好的，非常感谢。

这样就能解决我的问题了。呵呵