word文档合并并保留页面设置

zhanglei1371

今天遇到一个问题，就是将多个不同页面设置的文档合并到一个文档内，但是发现直接插入文档不行。
除非先插入分节符，然后打开要合并的文档==>全选==>复制==>粘贴。
懒得手工费事，打算搜索个代码，结果竟然没有发现论坛有类似代码。
而网上也没有好的合并工具，只找到一个在线合并的网站：
合并Word——免费在线合并Word文档  http://www.docpe.com/word/combine-word.aspx
但是不想每次都上传，就花时间写了这个代码：

Sub word文档合并()
Dim rg As Range, c As PageSetup
Dim fn As String, en As Single
Documents.Add
    fn = ActiveDocument.Name
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show <> -1 Then Exit Sub
        For Each f In .SelectedItems
            If InStr(f, "$") = 0 Then
                With Documents.Open(f, Visible:=False)
                    Set c = .PageSetup
                    With Documents(fn).Sections.Last.PageSetup
                        .Orientation = c.Orientation
                        .TopMargin = c.TopMargin
                        .BottomMargin = c.BottomMargin
                        .LeftMargin = c.LeftMargin
                        .RightMargin = c.RightMargin
                        .Gutter = c.Gutter
                        .HeaderDistance = c.HeaderDistance
                        .FooterDistance = c.FooterDistance
                        .PageWidth = c.PageWidth
                        .PageHeight = c.PageHeight
                        .SectionStart = c.SectionStart
                        .OddAndEvenPagesHeaderFooter = c.OddAndEvenPagesHeaderFooter
                        .DifferentFirstPageHeaderFooter = c.DifferentFirstPageHeaderFooter
                        .VerticalAlignment = c.VerticalAlignment
                        .SuppressEndnotes = c.SuppressEndnotes
                        .MirrorMargins = c.MirrorMargins
                        .BookFoldRevPrinting = c.BookFoldRevPrinting
                        .BookFoldPrintingSheets = c.BookFoldPrintingSheets
                        .GutterPos = c.GutterPos
                        .LayoutMode = c.LayoutMode
                    End With
                    en = Documents(fn).Range.End
                    Documents(fn).Range(en - 1, en - 1).InsertFile (f)
                   en = Documents(fn).Range.End
                    Documents(fn).Range(en - 1, en - 1).InsertBreak (2)
                    .Close 0
                End With
            End If
        Next
    End With
    MsgBox "恭喜,已合并完成!请查看新生成的文档----" & fn
End Sub

其实原理很简单，就是先插入文件，然后进行页面设置，再插入分节符==>再插入文件==>页面设置....
但是页面设置这里感觉又繁琐了。不知哪位有好的优化方案，或者更好的代码方案，欢迎拍砖....

weiyingde

我个人觉得，保留几个主要的参数就够了。
我有一个页面设计的一段代码。
看是否合意。

Public Sub 自定义页面(Paper As String, Bsh As String, TxtColm As Integer, Optional Wdh As Single, Optional Hgt As Single)
    On Error Resume Next
    Select Case Paper
           Case "A4"
                 wd = IIf(Bsh = "hb", 297, 210)
                 ht = IIf(Bsh = "hb", 210, 297)
                 lk = IIf(Bsh = "hb", 265, 178)
           Case "16K"
                 wd = IIf(Bsh = "hb", 260, 184)
                 ht = IIf(Bsh = "hb", 184, 260)
                 lk = IIf(Bsh = "hb", 228, 152)
           Case "zdy"
                 wd = IIf(Bsh = "hb", Hgt, Wdh)
                 ht = IIf(Bsh = "hb", Wdh, Hgt)
                 lk = IIf(Bsh = "hb", Hgt - 32, Wdh - 32)
    End Select
    With ActiveDocument.PageSetup
        .Orientation = IIf(Bsh = "hb", wdOrientLandscape, wdOrientPortrait) '2 页面方向为纵向;wdOrientLandscape--横向
        .PageWidth = MillimetersToPoints(wd)                                '纸张宽宽度厘米(mm)
        .PageHeight = MillimetersToPoints(ht)                               '纸张高宽度厘米(mm)
        .TopMargin = MillimetersToPoints(12)                                '上边距厘米(mm)
        .BottomMargin = MillimetersToPoints(12)                             '下边距厘米(mm)
        .LeftMargin = MillimetersToPoints(16)                               '左边距厘米(mm)
        .RightMargin = MillimetersToPoints(16)                              '右边距厘米(mm)
        .HeaderDistance = MillimetersToPoints(12.5)                         '页眉
        .FooterDistance = MillimetersToPoints(12.5)                         '页脚
        .Gutter = MillimetersToPoints(0)                                    '装订线
        .LayoutMode = wdLayoutModeDefault                                   '版式模式为无网络，作用：紧缩行距
        With .TextColumns                                                   '分栏设置
             .SetCount NumColumns:=TxtColm                                  '栏数
             .EvenlySpaced = True                                           '栏间距
             .LineBetween = False                                           '分栏线
            If TxtColm <> 1 Then .Width = MillimetersToPoints(lk)
        End With
    End With
End Sub