求助：如何将一个多页的word文档按页批量生成新word文件！

softbest4u

好帖子,收藏

himandy

c81 发表于 2007-3-1 14:02
吾有一简法，不知可行否：将每处你要分割的头句话设置成一个大纲级别（如果不是，用查找替换等方法生成）， ...

你好！我用了你的方法，非常好用。但有个问题请教，我发现文件名保存的时候，不是以word文档第一句作为文件名的，而是以原文件名再自动添加数字。请问怎样实现用第一句作为文件名保存呢？谢谢！

himandy

搞定了，原来第一句的中间要连贯，不能有标点符号。我用邮件合并，在第一句插入了一个合并域，实现自动命名了。非常感谢各位高手

dygcs

守柔 发表于 2007-3-3 17:18
做了一个适用于WORD 2003及其以上版本的程序，具有一定通用性，可作为加载宏使用。以下代码供参考：'* ＋＋ ...

守柔兄的程序我试用了，想提一下两点改进意见：
1.您的程序是逐页保存，能否改进成 所有奇数页 或者  偶数页 保存？？？
2.能否让WORD代码只对奇数页或者偶数页执行？？？

dygcs

做了一个适用于WORD 2003及其以上版本的程序，具有一定通用性，可作为加载宏使用。以下代码供参考：'* ＋＋ ...

守柔兄的程序我试用了，想提一下两点改进意见：
1.您的程序是逐页保存，能否改进成 所有奇数页 或者  偶数页 保存？？？
2.能否让WORD代码只对奇数页或者偶数页执行？？？

dygcs

word打印的时候能够奇偶分开，也应该能够实现奇偶另存的功能，希望大家一起努力找到方法，可以解决很多困难

zhanglei1371

dygcs 发表于 2013-10-16 09:59
word打印的时候能够奇偶分开，也应该能够实现奇偶另存的功能，希望大家一起努力找到方法，可以解决很多困难

奇偶页另存很容易做到，不过没什么意义

dygcs

奇偶页另存对于我的应用有意义啊，请教

相见是缘8

守柔 发表于 2007-3-3 17:22
        Set myDoc = Documents.Add(Visible:=False)  &nbs ...

不知什么原因，代码运行提示：运行时错误 ’13’，类型不匹配。

Option Explicit

SubSaveAsFileByPage()

    Dim ThisDoc As Document, myDoc As Document,oPage As Page, strName As String

    Dim myDialog As FileDialog, myFolder AsString, myArray() As String

    Dim myRange As Range, PageString As String,pgOrientation As WdOrientation

    Dim sinLeft As Single, sinRight As Single,sinTop As Single, sinBottom As Single

    Dim ErrChar() As Variant, oChar As Variant,sinStart As Single, sinEnd As Single

    Const myMsgTitle As String ="ExcelHome_ShouRou"

    If Val(Application.Version) < 11 ThenMsgBox "此程序需要运行在Word2003及其以上版本中!", vbInformation, myMsgTitle: Exit Sub

    sinStart = Timer

    On Error GoTo ErrHandle    '设置错误处理

    '定义一个FileDialog对象,为文件夹选取对话框

    Set myDialog =Application.FileDialog(msoFileDialogFolderPicker)

    With myDialog

        If .Show <> -1 Then Exit Sub    '如果未确定则退出

        myFolder = .InitialFileName    '取得文件夹路径

    End With

    Application.ScreenUpdating = False    '关闭屏幕更新

    Set ThisDoc = ActiveDocument    '定义一个Document对象,以利用本程序作为加载宏

    '文件自动命名时必须规避的字符

    ErrChar = Array("\","/", ":", "*", "?","""", "<", ">", "|")

    '在文档的每页中循环

For Each oPage InThisDoc.ActiveWindow.ActivePane.Pages

        '取得文档的文本层内容,此处的Item可根据实际情况修改,其值为0-5

        Set myRange = oPage.Rectangles(1).Range

        '取得一个以段落标记为分隔符的一维数组

        myArray = VBA.Split(myRange.Text,Chr(13))

        '将所有文本合并为一个字符串

        PageString = VBA.Join(myArray,"")

        '取得文档中每节的页面设置

        With myRange.Sections(1).PageSetup

            sinLeft = .LeftMargin    '左页边距

            sinRight = .RightMargin    '右页边距

            sinTop = .TopMargin    '上边距

            sinBottom = .BottomMargin    '下边距

            pgOrientation = .Orientation    '纸张方向

        End With

        For Each oChar In ErrChar    '进行一系列替换,即删除无效字符

            PageString = VBA.Replace(PageString,oChar, "")

        Next

        strName = VBA.Left(PageString, 20)    '取得一个前二十个字符的文件名

        strName = strName &".doc"

        myRange.Copy    '复制

Set myDoc = Documents.Add(Visible:=False)    '新建一个隐藏的空白文档

        With myDoc

            .Content.Paste    '粘贴

           .Content.Paragraphs.Last.Range.Delete   '删除最后一个段落标记

            With .PageSetup    '进行页面设置

                .Orientation = pgOrientation

                .LeftMargin = sinLeft

                .RightMargin = sinRight

                .TopMargin = sinTop

                .BottomMargin = sinBottom

            End With

            '如果有相同的文档,则自动随时间序数命名

            If VBA.Dir(myFolder & strName,vbDirectory) <> "" Then strName = Timer & ".doc"

            .SaveAs myFolder & strName    '另存为

            .Close    '关闭文档

        End With

    Next

    ThisDoc.Characters(1).Copy    '变相清空剪贴板

    Application.ScreenUpdating = True    '恢复屏幕更新

    sinEnd = Timer    '取得代码运行结束的时间

    If MsgBox("分页保存结束,用时:"& sinEnd - sinStart & _

              "秒,是否打开指定文件夹查看分页保存后的文档情况?",vbYesNo, myMsgTitle) = vbYes Then _

       ThisDoc.FollowHyperlink myFolder

    Exit Sub

ErrHandle:

    MsgBox "错误号:" & Err.Number & vbLf & "出错原因:" & Err.Description, myMsgTitle

    Err.Clear

    Application.ScreenUpdating = True    '恢复屏幕更新

End Sub