当前WORD每页生成一个文档

yjwdjfqb

当前WORD每页生成一个文档

这个里面的代码，可以将一个WORD文档的每页生成一个新的文档，但唯一的不足就是，导出的文档不能保持原文件的格式。

请朋友们，在这个基础上把这个功能加上好吧，谢谢大家了！

当前WORD每页生成一个文档.rar (9.26 KB, 下载次数: 72)

2014-3-30 18:30 上传

点击文件名下载附件

cbtaja

保持格式最好的办法是将其“图形化”，比如转换为pdf文件——如果能接受的话，这将很简单：

首先，使用pdf虚拟打印机把word文档整体转换为pdf文档，
然后，使用PDFSpliter软件将所得的pdf文档拆分为单页pdf文档即可。

yjwdjfqb

cbtaja 发表于 2014-3-30 19:30
保持格式最好的办法是将其“图形化”，比如转换为pdf文件——如果能接受的话，这将很简单：

首先，使用p ...

PDF固然能保持不变的格式，

但，想导出的文档想进行编辑又是一个问题

所在还是想，导出以WORD的形式，并保持原文件格式。

希望大侠们能帮帮忙！

huanger999

我的想法是，将文件复制若干份，然后按照顺序，每份删除的只剩下一页就好了。

hellohaoyu1985

利用Copy和Paste会完成这个例题。
注意的是本人没写任何错误处理(生成两次就会报错），运行程序后，在所在文档会生成一个拆分文件夹，里面就是被拆分的文件。

1. 
   
2. Sub 分割文档()
   
3. Dim PageCount As Integer, SavePath As String
   
4. PageCount = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
   
5. SavePath = ActiveDocument.Path & "\拆分"
   
6. MkDir SavePath
   
7. Selection.SetRange 0, 0
   
8. Dim tmpDoc As Document, e&
   
9. For e = 1 To PageCount
   
10.     Selection.Bookmarks("\page").Select
    
11.     Selection.Copy
    
12.     Set tmpDoc = Documents.Add
    
13.     tmpDoc.Range.Paste
    
14.     tmpDoc.SaveAs SavePath & "\第" & CStr(e) & "页"
    
15.     tmpDoc.Close
    
16.     Selection.GoToNext wdGoToPage
    
17. Next
    
18. End Sub

复制代码

另外关于Selection的选择还有一些其它的办法，可以搜一下老帖。我这种办法不用IF语句。

loquat

使用Selection对象时，如不关闭屏幕刷新，将会至少降低一倍效率。
以下不使用Selection对象

1. Sub 分割文档()
   
2. Application.ScreenUpdating = False
   
3. Dim PageCount&, SavePath$
   
4. Dim oStart&, oEnd&, aPage&
   
5. PageCount = ThisDocument.ComputeStatistics(wdStatisticPages)
   
6. SavePath = ThisDocument.Path & "\拆分"
   
7. MkDir SavePath
   
8. For aPage = 1 To PageCount
   
9.     oStart = .GoTo(wdGoToPage, wdGoToAbsolute, aPage).Start
   
10.     oEnd = .GoTo(wdGoToPage, wdGoToAbsolute, aPage + 1).Start
    
11.     aDoc.Range(oStart, oEnd).Copy
    
12.     With Documents.Add
    
13.         .Range.Paste
    
14.         .SaveAs SavePath & "\第" & CStr(i) & "页"
    
15.         .Close
    
16.     End With
    
17. Next
    
18. Application.ScreenUpdating = True
    
19. End Sub

复制代码

yjwdjfqb

谢谢朋友们的帮助！

psystyle

loquat 发表于 2014-4-9 00:21
使用Selection对象时，如不关闭屏幕刷新，将会至少降低一倍效率。
以下不使用Selection对象

运行，出现编译错误的提示。

loquat

看似简单的代码写起来还是蛮复杂的，容错还是没有写完。。。

1. Sub 分割文档()
   
2. Application.ScreenUpdating = False
   
3. Dim PageCount&, SavePath$, aPage&, specialStr$
   
4. Dim oStart&, oEnd&, aDoc As Document
   
5. Set aDoc = ThisDocument
   
6. PageCount = aDoc.ComputeStatistics(wdStatisticPages)    '获取总页数
   
7. SavePath = aDoc.Path & "\拆分"                          '保存目录
   
8. If Dir(SavePath, vbDirectory) = "" Then MkDir SavePath  '如果目录不存在就建立目录
   
9. For aPage = 1 To PageCount                              '循环处理所有页
   
10.     oStart = aDoc.GoTo(wdGoToPage, wdGoToAbsolute, aPage).Start    '本页页首坐标
    
11.     If aPage < PageCount Then
    
12.         oEnd = aDoc.GoTo(wdGoToPage, wdGoToAbsolute, aPage + 1).Start  '次页页首坐标
    
13.     Else
    
14.         oEnd = aDoc.Content.End
    
15.     End If
    
16.     specailStr = Chr(11) & Chr(12) & Chr(13) & Chr(14) '页尾特殊字符列表
    
17.     If InStr(1, specialStr, aDoc.Range(oEnd - 1, oEnd).Text, vbBinaryCompare) <> 0 Then  '页尾是特殊字符时
    
18.         oEnd = oEnd - 1                                '坐标向前移动一位
    
19.     End If
    
20.     aDoc.Range(oStart, oEnd).Copy                  '复制页内容
    
21.     With Documents.Add                                 '新建文档，粘贴，另存
    
22.         .Range.Paste
    
23.         .SaveAs SavePath & "\第" & CStr(aPage) & "页"
    
24.         .Close
    
25.     End With
    
26. Next
    
27. Application.ScreenUpdating = True
    
28. End Sub

复制代码

yjwdjfqb

loquat 发表于 2014-4-9 21:26
看似简单的代码写起来还是蛮复杂的，容错还是没有写完。。。

感谢朋友的耐心解答，如果能解决，导出的页有空白页就更好了，如本例中第三页就有一个空白，不过，已经很好了，感谢朋友！