[原创并分享]分页保存

守柔

成品如下，可作为加载宏加载。

  RgRyQaem.zip (12.04 KB, 下载次数: 1888)

2007-3-5 11:50 上传

点击文件名下载附件
[原创并分享]分页保存

以下代码供参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-3-5 6:50:15
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0174^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub SaveAsFileByPage()
'分页保存,适用于WORD97及其以上版本
    Dim objShell As Object, objFolder As Object, strNameLenth As Integer
    Dim mySelection As Selection, myFolder As String, myArray() As String
    Dim ThisDoc As Document, myDoc As Document, strName As String, N As Integer
    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"
    Dim vbYN As VbMsgBoxResult
    sinStart = Timer
    On Error GoTo ErrHandle    '设置错误处理
    '创建一个Shell.Application对象
    Set objShell = CreateObject("Shell.Application")
    '取得文件夹浏览器
    Set objFolder = objShell.BrowseForFolder(0, "请选择一个文件夹", 0, 0)
    If objFolder Is Nothing Then Exit Sub
    myFolder = objFolder.Self.Path & "\"
    Set objFolder = Nothing: Set objShell = Nothing
    Set ThisDoc = ActiveDocument    '定义一个Document对象,以利用本程序作为加载宏
    Set mySelection = ThisDoc.ActiveWindow.Selection
    '文件自动命名时必须规避的字符
    ErrChar = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    '一些特列字符
    For N = 0 To 31
        ReDim Preserve ErrChar(UBound(ErrChar) + 1)
        ErrChar(UBound(ErrChar)) = Chr(N)
    Next

[此贴子已经被作者于2007-3-5 11:56:17编辑过]

守柔

    strNameLenth = Val(VBA.InputBox(prompt:="请输入您需要设置的文件名长度,0或者取消将自动命名!", Title:=myMsgTitle, Default:=10))
    If strNameLenth > 255 Then strNameLenth = 0
    vbYN = MsgBox("是否需要处理页尾的分隔符(分页符/分节符)?它可能会影响文档结构.", vbYesNo + vbInformation + vbDefaultButton2, myMsgTitle)
    Application.ScreenUpdating = False    '关闭屏幕更新
    '在文档的每页中循环
    For N = 1 To mySelection.Information(wdNumberOfPagesInDocument)
        mySelection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=N
        Set myRange = ThisDoc.Bookmarks("\PAGE").Range
        If vbYN = vbYes And VBA.Asc(myRange.Characters.Last.Text) = 12 Then _
           myRange.SetRange myRange.Start, myRange.End - 1
        '取得一个以段落标记为分隔符的一维数组
        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

守柔

        If strNameLenth = 0 Then
            strName = ThisDoc.Name
            strName = VBA.Replace(LCase(strName), ".doc", "")
            strName = strName & "_" & N
        Else
            strName = VBA.Left(PageString, strNameLenth)    '取得文件名
        End If
        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 = "Page_" & N & ".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
'----------------------

相关链接与代码：

http://club.excelhome.net/viewthread.php?tid=120411&replyID=&skin=0

http://club.excelhome.net/viewthread.php?tid=223214&px=0

http://club.excelhome.net/viewthread.php?tid=54513&replyID=245406&skin=0

[此贴子已经被作者于2007-3-5 11:59:54编辑过]

konggs

谢谢老大分享。辛苦了。[em17]

konggs

老大的附件与传上来的代码不一样啊？

守柔

QUOTE:

以下是引用konggs在2007-3-5 8:59:57的发言：
老大的附件与传上来的代码不一样啊？

谢谢孔兄，由于此前做了三个分页保存的程序，故在压缩过程中，由于文件名一致，而被压缩在一起了，加上临近上班，也未检查，已删除另一个分页保存（以PAGE对象）文档。

说明：

1.        可以作用加载宏以方便调用，运行时单击菜单栏最后侧的“分页保存”命令即可。

2.        用户可以自行选择/新建文件夹，并将分页保存结果保存于用户文件夹中。

3.        具有自动筛选功能，避免文档中可能导致的文件命名错误。

4.        可由用户指定文件名长度，如果未指定或者错误的指定，将采用自动命名方式。

5.        适用性更广，采用SHELL对象的文件夹浏览方式，规避了WORD2000及以下版本中不支持的FileDialog对象。

6.        具有分节页面保留功能，支持“主文档”中的多节页面设置。

7.        可由用户决定是否保留页尾分隔符。

守柔

我把代码移一块儿了，把cfxxfc版主的回贴移一下。

FENGJUN

守柔兄：

此工具在对我的附件进行操作时产生“类型不匹配”错误，中断。不明原因，请援手

AJDuTNtr.rar (5.56 KB, 下载次数: 200)

2007-4-18 10:11 上传

点击文件名下载附件
[原创并分享]分页保存

[此贴子已经被作者于2007-4-18 10:12:41编辑过]

rainer_k

如果需要将分页符或者分节符间的内容分别存为单个文件，怎么处理？
谢谢！