请大佬帮忙修改gms下，页面合并与分页

zhucheyong

从cnprint论坛找到的比较老的代码。代码如下

1. '         页面合并与分布
   
2. Function BeginOpt(Name As String)
   
3.     ActiveDocument.BeginCommandGroup Name
   
4.     ActiveDocument.SaveSettings
   
5.     ActiveDocument.Unit = CDRMillimeter
   
6.     ActiveDocument.ReferencePoint = cdrTopLeft
   
7.     ActiveDocument.DrawingOriginX = 0
   
8.     ActiveDocument.DrawingOriginY = 0
   
9.     Optimization = True
   
10.     EventsEnabled = False
    
11.     ActiveDocument.SaveSettings
    
12.     ActiveDocument.PreserveSelection = False
    
13. End Function
    
14. 
    
15. Function EndOpt()
    
16.     ActiveDocument.PreserveSelection = True
    
17.     ActiveDocument.RestoreSettings
    
18.     EventsEnabled = True
    
19.     Optimization = False
    
20.     Application.Refresh
    
21.     Application.CorelScript.RedrawScreen
    
22.     ActiveDocument.EndCommandGroup
    
23.     Beep
    
24. End Function
    
25. 
    
26. Sub 分布页面()
    
27. Dim doc As Document, s As Shape, n As Integer, sCnut As Integer
    
28. Dim Size_x As Double, Size_y As Double, dInd As Integer, pCou As Integer
    
29. On Error GoTo Er
    
30. 
    
31.     Set doc = ActiveDocument
    
32.     If Documents.Count = 0 Then MsgBox "没有文件被打开。": Exit Sub
    
33.     If doc.Selection.Shapes.Count = 0 Then MsgBox "请选择一个或多个分布对象。": Exit Sub
    
34.     BeginOpt "分布页面"
    
35.    
    
36.     doc.ActivePage.GetSize Size_x, Size_y
    
37.     pCou = doc.Pages.Count
    
38.     dInd = doc.ActivePage.Index
    
39.    
    
40.     For Each s In ActiveSelectionRange()
    
41.         doc.InsertPagesEx 1, 0, pCou, Size_x, Size_y
    
42.         s.MoveToLayer doc.Pages(pCou + 1).ActiveLayer
    
43.         If Application.VersionMajor > 15 Then _
    
44.         s.AlignAndDistribute 3, 3, 1, 0, 0, 2 Else s.AlignToPageCenter 15, 2
    
45.     Next s
    
46. 
    
47.     doc.Pages(dInd).Activate
    
48. Er: EndOpt
    
49.    
    
50. End Sub
    
51. 
    
52. Sub 合并页面()
    
53. Dim doc As Document, sr As ShapeRange, dInd As Integer, pCou As Integer, n As Integer
    
54. Dim Size_x As Double, Size_y As Double, nCol As Double, nRow As Double, x As Integer, y As Integer
    
55. On Error GoTo Er
    
56. 
    
57.     Set doc = ActiveDocument
    
58.     If Documents.Count = 0 Then MsgBox "没有文件被打开。": Exit Sub
    
59.     If doc.Selection.Shapes.Count = 0 Then MsgBox "请选择当前页的合并对象，拼版将使用它的尺寸。": Exit Sub
    
60.    
    
61.     BeginOpt "合并页面"
    
62.    
    
63.     ActiveSelectionRange.GetSize Size_x, Size_y
    
64.     pCou = doc.Pages.Count
    
65.     dInd = doc.ActivePage.Index
    
66.     If pCou < 1 Or pCou - dInd < 1 Then MsgBox "起始页之后没有可合并的页面。": Exit Sub
    
67.   
    
68. Re: nCol = InputBox(vbCrLf & "  请告诉我你要排成几列？", "合并页面_LinSong", Round(Sqr(pCou - dInd + 1)))
    
69. 
    
70.         If nCol > 0 And nCol < (pCou - dInd + 1) Then
    
71.             nRow = IIf((pCou - dInd + 1) / nCol > Round((pCou - dInd + 1) / nCol), _
    
72.             Round((pCou - dInd + 1) / nCol) + 1, Round((pCou - dInd + 1) / nCol))
    
73.         Else
    
74.             MsgBox "输入的数值超出了可操作页数范围，请重新输入。": GoTo Re
    
75.         End If
    
76. 
    
77.    doc.DrawingOriginX = Size_x
    
78.     doc.DrawingOriginY = Size_y
    
79.    
    
80.     x = 1: y = nRow
    
81.     For n = 0 To pCou - dInd
    
82.         Set sr = doc.CreateShapeRangeFromArray(doc.Pages(dInd + n).Shapes.All)
    
83.             sr.RemoveRange doc.Pages(All).DesktopLayer.Shapes.All
    
84.             sr.RemoveRange doc.Pages(All).GuidesLayer.Shapes.All
    
85.             sr.Group
    
86.             sr.MoveToLayer doc.Pages(dInd).ActiveLayer
    
87.         If x > nCol Then y = y - 1: x = 1
    
88.         sr.SetPosition Size_x * (x - 1), Size_y * y: x = x + 1
    
89.     Next n
    
90.    doc.DeletePages dInd + 1, pCou - dInd
    
91. Er: EndOpt
    
92.    
    
93. End Sub
    

复制代码

现在有两个问题1.分布页面后，起始页从第二页开始了，第一页空白了，请问怎么修改从第一页开始分页？
2.如果没有选中对象，合并页面后，会造成整个页面假死，

jiangyu

第一个事件试试把s.MoveToLayer doc.Pages(pCou + 1).ActiveLayer这句改成s.MoveToLayer doc.Pages(（pCou-1） + 1).ActiveLayer试试看。第二个事件试试在on error goto er的er事件那里加入exit sub，或者修改一下是否有选中对象那里的判定，由对象数改成对象IS nothing，或者对象=“”，多尝试一下吧

zhucheyong

jiangyu 发表于 2021-12-17 17:27
第一个事件试试把s.MoveToLayer doc.Pages(pCou + 1).ActiveLayer这句改成s.MoveToLayer doc.Pages(（pCou- ...

请问第一个事件，我加一句删除页面1，为什么会把后面的页面删除了
s.DeletePages (1)

zhucheyong

jiangyu 发表于 2021-12-17 17:27
第一个事件试试把s.MoveToLayer doc.Pages(pCou + 1).ActiveLayer这句改成s.MoveToLayer doc.Pages(（pCou- ...

第一个事件加
doc.DeletePages 1, pCou
解决问题
第二个事件 If pCou < "1" Or pCou - dInd < "1" Then MsgBox "起始页之后没有可合并的页面。": Exit Sub
为什么会卡死呢
把on error goto er的er事件那里加入exit sub，或删除了，还是不行，运行后卡死了

补充内容 (2021-12-18 10:22):
解决问题把exit改成.End  .close 也是 也一样的效果 s.Sub.End不会卡死了

petergh

终于找到我需要的代码,太感谢了!