TO——守柔：邮件合并后分拆成单个文档保存的代码应用问题请教

map123

守柔版主您好！我正在处理一个邮件合并文档发，大约有195个合并邮件，每个邮件有固定格式（单个文档有10页），版面都 排好，但想把他们能分别 保存成单个文件，偶尔看到您的大作——“分页保存-保留格式设置的代码”，但我应用不成功，也不会修改，能否帮我修改一下代码让我直接能复制应用，文档名自动安顺序号保存即可，如194个文件按001，002，。。。。到194，如能赐教，本人在此不胜感激！

分页保存-保留格式设置的代码
Sub SaveAsPage()
Dim PageCount As Integer, StartRange As Long, EndRange As Long, MyRange AsRange
Dim Fn As String, MyDoc As Document, MyHeader As Range, MyFooter As Range
On Error Resume Next
With Selection
PageCount = .Information(wdNumberOfPagesInDocument)
.HomeKey unit:=wdStory
For i = 1 To PageCount
StartRange = .Start
Set MyHeader = .Sections(1).Headers(wdHeaderFooterPrimary).Range
MsgBox MyHeader
MyHeader.Copy
Set MyFooter = .Sections(1).Footers(wdHeaderFooterPrimary).Range
MsgBox MyFooter
Set MyDoc = Documents.Add'原现有光标所在页的页面设置赋值给新文档
WithApplication.Windows(ThisDocument.Name).Selection.Sections(1).PageSetup ActiveDocument.Sections(1).PageSetup.TopMargin = .TopMargin ActiveDocument.Sections(1).PageSetup.BottomMargin
= .BottomMargin
= .RightMargin
ActiveDocument.Sections(1).PageSetup.LeftMargin = .LeftMargin
ActiveDocument.Sections(1).PageSetup.RightMargin
ActiveDocument.Sections(1).PageSetup.Orientation = .Orientation
EndRange
End With
With ActiveDocument '打开页眉页脚
.ActiveWindow.View.SeekView = wdSeekCurrentPageHeader
With Application.Windows(MyDoc).Selection
.Paste '粘贴其中内容并删除最后一个段落标记
.Paragraphs(.Paragraphs.Count).Range.Delete
End With '关闭页眉页脚
.ActiveWindow.View.SeekView = wdSeekMainDocument
.ActiveWindow.View.Type = wdPrintView
End With
ThisDocument.Activate
Fn = i & ActiveDocument.Name
If i = PageCount Then        '如果循环到达最后一页
EndRange = ActiveDocument.Content.End        '将文档最后位置赋值于
Else
EndRange = .GoToNext(wdGoToPage).Start        '否则,将下一页的起始位置赋值于 EndRange(等同于本页的最后位置) End If
Set MyRange = ActiveDocument.Range(StartRange, EndRange)        '将本页中的内容进行复制
MyRange.Copy
With Application.Windows(MyDoc).Selection
.Paste
.Paragraphs(.Paragraphs.Count).Range.Delete
.Find.Execute        findtext:="^m",        Replacewith:="", Replace:=wdReplaceAll
MyDoc.SaveAs FileName:=Fn       
MyDoc.Close       
End With
Next

End With
End Sub

szqhb

Sub 每N页分割为一个新文档__保存到同目录下()
'特别鸣谢"雨雪霏霏、守柔版主。
    Dim MyPath As String, PageCount As Integer
    Dim StartRange As Long, EndRange As Long, MyRange As Range
    Dim Fn As String, MyDoc As Document, i As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    MyPath = ActiveDocument.Path    '取得文档路径
    PageCount = Selection.Information(wdNumberOfPagesInDocument)    '取得文档总页数
    N = InputBox("按每几页拆分？默认为10：", "请输入数值", 10)
    Selection.HomeKey unit:=wdStory    '将光标移至文档起点
    For i = 1 To PageCount / N + (PageCount Mod N)    '设置循环次数，如3则表示每3页做一次循环
        StartRange = Selection.Start    '取得该页的第一个字符位置
        Selection.EndKey unit:=wdLine    '将光标移动到该页首行的最后位置
        Fn = i & ActiveDocument.Name    '-1的目的是防止该页首行含有段落标记,导致出错.
        If i * N >= PageCount Then    '如果循环到达最后一页
            EndRange = ActiveDocument.Content.End    '将文档最后位置赋值于EndRange
        Else
           For J = 1 To N
            Selection.GoToNext (wdGoToPage)
            Next J
            EndRange = Selection.Start
        End If
        Set MyRange = ActiveDocument.Range(StartRange, EndRange)  '将N页中的内容进行复制
        MyRange.Copy
        Set MyDoc = Documents.Add    '新建一空白文档
        With MyDoc
             .Content.Paste    '在新文档中粘贴
             .Content.Paragraphs.Last.Range.Delete '删除新文档末尾多出来的一个段落标记
             .SaveAs FileName:=MyPath & "/" & Fn
             '保存新文档到原文档所在目录。如果删除"MyPath & "/" & "，。则保存到"我的文档"中。
             .Close    '关闭新文档
        End With
    Next
    Application.ScreenUpdating = True
End Sub

map123

谢谢szqhb 楼主指点！

tangqingfu

谢谢szqhb兄的分享，收藏学习！
对于含表格的文档，处理效果好像不是很好！

[ 本帖最后由 tangqingfu 于 2011-2-24 18:01 编辑 ]

sqhsqhli

此贴要收藏

softbest4u

每N页分割为一个新文档, 计算一下也不错

萁實涐卟認識伱

我是新手。请问这个怎么有的啊

huguifang

纸张横向的处理也不好，期待完善

゛③оρゝ痕

留印备用！留印备用！！{:soso_e113:}

ok520

szqhb 发表于 2011-1-25 21:59
Sub 每N页分割为一个新文档__保存到同目录下()
'特别鸣谢"雨雪霏霏、守柔版主。
    Dim MyPath As Strin ...

新的文档如何默认是只读模式尼？