word中的一页自动生成一个文件

lan_yu

请教一下各位高手，如何在WORD中，让每一页自动生成一个文件，文件名为每一页的第一行，并存在指定的目录。

fengbin7506

这个得用VBA解决吧。

lan_yu

原帖由 fengbin7506 于 2010-10-13 08:06 发表
这个得用VBA解决吧。

怎么解决，谢谢！

szqhb

这个是“守柔”大师的杰作，稍微“润色”了一下
务必讲代码将代码粘贴于活动文档的“THISDOCUMENT”模块中才能运行哦

还有一个就是每页的首行不能为空及文档命名系统不允许的符号

Sub shouroude()
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 = Range(StartRange, Selection.End - 1) '-1的目的是防止该页首行含有段落标记,导致出错.
        If i = PageCount Then '如果循环到达最后一页
        EndRange = ActiveDocument.Content.End '将文档最后位置赋值于EndRange
        Else
        Selection.GoToNext (wdGoToPage) '否则,将下一页的起始位置赋值于EndRange(等同于本页的最后位置)
        EndRange = Selection.Start - 1
        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
    MsgBox "操作完毕!" & vbCrLf & "请到“我的文档”文件夹查看！！", vbInformation
End Sub

将拆分的文档存放在当前文件夹不知怎样修改代码

[ 本帖最后由 szqhb 于 2010-10-14 09:51 编辑 ]

守柔

原帖由 lan_yu 于 2010-10-12 22:43 发表
请教一下各位高手，如何在WORD中，让每一页自动生成一个文件，文件名为每一页的第一行，并存在指定的目录。

楼主如果对于VBA不熟悉，可以考虑使用《守柔Word文档切割机》。
请参考此链接：
http://www.rousoft.com.cn/product_content.asp?ArticleID=168

nimenhao

守柔Word文档切割机和那个排版的我想要，在哪里啊

守柔

原帖由 nimenhao 于 2010-10-14 07:12 发表
守柔Word文档切割机和那个排版的我想要，在哪里啊

请参考：
http://shop57134256.taobao.com/

lan_yu

原帖由 szqhb 于 2010-10-13 21:54 发表
这个是“守柔”大师的杰作，稍微“润色”了一下
务必讲代码将代码粘贴于活动文档的“THISDOCUMENT”模块中才能运行哦

还有一个就是每页的首行不能为空及文档命名系统不允许的符号

Sub shouroude()
Dim PageC ...

非常感谢szqhb 的热心帮助！如果存在两页或多页存为一个文档，因为一个单位（即标题）有多页的情况。谢谢！

szqhb

原帖由 lan_yu 于 2010-10-15 09:21 发表

非常感谢szqhb 的热心帮助！如果存在两页或多页存为一个文档，因为一个单位（即标题）有多页的情况。谢谢！

不太懂你现在所述的意思，你的要求就是每页存为一个文档啊
如果你是以标题为标志来拆分也是可以的，每个标题必须是统一的字体字号，Home中有相关的例子，自己搜索一下看看
下面是以各标题为二号宋体来拆分的代码

Sub 拆分Word()
Dim myDoc As Document, mytitle As String, a As String, i As Byte
Dim lngStart As Long, lngEnd As Long, myStart As Long, n As Integer
Application.ScreenUpdating = False
Set myDoc = ActiveDocument
myDoc.ActiveWindow.WindowState = wdWindowStateMinimize
a = "\/:*?""<>|"
With myDoc.Content.Find
    .ClearFormatting
    .Font.Name = "宋体"   '各独立小文档标题字体
    .Font.Size = 22  '各独立小文档标题字号，22号即二号字体
    .Format = True
    Do While .Execute
        n = n + 1
        With .Parent
            lngStart = .Start
            lngEnd = .Paragraphs(1).Range.End
            .MoveUntil Chr(13), wdBackward
            If n > 1 Then
                Documents.Add.Content.FormattedText = myDoc.Range(IIf(n = 2, 0, myStart), .Start).FormattedText
                ActiveDocument.SaveAs myDoc.Path & "\" & mytitle & ".doc"
                'ActiveDocument.SaveAs Replace(myDoc.FullName, ".doc", "") & "_" & n - 1 & ".doc"
                ActiveDocument.Close
            End If
            mytitle = Trim(myDoc.Range(lngStart, lngEnd - 1).Text)
            For i = 1 To Len(a)
                mytitle = Replace(mytitle, Mid(a, i, 1), "")
            Next
            myStart = .Start
            .SetRange lngEnd, lngEnd
        End With
    Loop
    If n > 1 Then
        Documents.Add.Content.FormattedText = myDoc.Range(myStart, myDoc.Content.End).FormattedText
        ActiveDocument.SaveAs myDoc.Path & "\" & mytitle & ".doc"
        'ActiveDocument.SaveAs Replace(myDoc.FullName, ".doc", "") & "_" & n & ".doc"
        ActiveDocument.Close
    End If
End With
Application.ScreenUpdating = True
myDoc.ActiveWindow.WindowState = wdWindowStateNormal
MsgBox IIf(n > 1, "已将活动文档拆分并另存为" & n & "个小文档。", "活动文档不具备指定的拆分条件。")
End Sub

[ 本帖最后由 szqhb 于 2010-10-19 23:55 编辑 ]

lan_yu

原帖由 szqhb 于 2010-10-15 11:40 发表

不太懂你现在所述的意思，你的要求就是每页存为一个文档啊
如果你是以标题为标志来拆分也是可以的，每个标题必须是统一的字体字号，Home中有相关的例子，自己搜索一下看看
下面是以各标题为二号宋体来拆分的代码 ...

非常感谢！就是要达到您这个结果。但这段代码运行后无法拆分，总是显示“活动文档不具备指定的拆分条件”，请教一下怎么解决！

[ 本帖最后由 lan_yu 于 2010-10-19 21:10 编辑 ]