请大佬帮忙修改gms下，页面合并与分页
从cnprint论坛找到的比较老的代码。代码如下' 页面合并与分布
Function BeginOpt(Name As String)
ActiveDocument.BeginCommandGroup Name
ActiveDocument.SaveSettings
ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrTopLeft
ActiveDocument.DrawingOriginX = 0
ActiveDocument.DrawingOriginY = 0
Optimization = True
EventsEnabled = False
ActiveDocument.SaveSettings
ActiveDocument.PreserveSelection = False
End Function
Function EndOpt()
ActiveDocument.PreserveSelection = True
ActiveDocument.RestoreSettings
EventsEnabled = True
Optimization = False
Application.Refresh
Application.CorelScript.RedrawScreen
ActiveDocument.EndCommandGroup
Beep
End Function
Sub 分布页面()
Dim doc As Document, s As Shape, n As Integer, sCnut As Integer
Dim Size_x As Double, Size_y As Double, dInd As Integer, pCou As Integer
On Error GoTo Er
Set doc = ActiveDocument
If Documents.Count = 0 Then MsgBox "没有文件被打开。": Exit Sub
If doc.Selection.Shapes.Count = 0 Then MsgBox "请选择一个或多个分布对象。": Exit Sub
BeginOpt "分布页面"
doc.ActivePage.GetSize Size_x, Size_y
pCou = doc.Pages.Count
dInd = doc.ActivePage.Index
For Each s In ActiveSelectionRange()
doc.InsertPagesEx 1, 0, pCou, Size_x, Size_y
s.MoveToLayer doc.Pages(pCou + 1).ActiveLayer
If Application.VersionMajor > 15 Then _
s.AlignAndDistribute 3, 3, 1, 0, 0, 2 Else s.AlignToPageCenter 15, 2
Next s
doc.Pages(dInd).Activate
Er: EndOpt
End Sub
Sub 合并页面()
Dim doc As Document, sr As ShapeRange, dInd As Integer, pCou As Integer, n As Integer
Dim Size_x As Double, Size_y As Double, nCol As Double, nRow As Double, x As Integer, y As Integer
On Error GoTo Er
Set doc = ActiveDocument
If Documents.Count = 0 Then MsgBox "没有文件被打开。": Exit Sub
If doc.Selection.Shapes.Count = 0 Then MsgBox "请选择当前页的合并对象，拼版将使用它的尺寸。": Exit Sub
BeginOpt "合并页面"
ActiveSelectionRange.GetSize Size_x, Size_y
pCou = doc.Pages.Count
dInd = doc.ActivePage.Index
If pCou < 1 Or pCou - dInd < 1 Then MsgBox "起始页之后没有可合并的页面。": Exit Sub
Re: nCol = InputBox(vbCrLf & "请告诉我你要排成几列？", "合并页面_LinSong", Round(Sqr(pCou - dInd + 1)))
If nCol > 0 And nCol < (pCou - dInd + 1) Then
nRow = IIf((pCou - dInd + 1) / nCol > Round((pCou - dInd + 1) / nCol), _
Round((pCou - dInd + 1) / nCol) + 1, Round((pCou - dInd + 1) / nCol))
Else
MsgBox "输入的数值超出了可操作页数范围，请重新输入。": GoTo Re
End If
doc.DrawingOriginX = Size_x
doc.DrawingOriginY = Size_y
x = 1: y = nRow
For n = 0 To pCou - dInd
Set sr = doc.CreateShapeRangeFromArray(doc.Pages(dInd + n).Shapes.All)
sr.RemoveRange doc.Pages(All).DesktopLayer.Shapes.All
sr.RemoveRange doc.Pages(All).GuidesLayer.Shapes.All
sr.Group
sr.MoveToLayer doc.Pages(dInd).ActiveLayer
If x > nCol Then y = y - 1: x = 1
sr.SetPosition Size_x * (x - 1), Size_y * y: x = x + 1
Next n
doc.DeletePages dInd + 1, pCou - dInd
Er: EndOpt
End Sub
现在有两个问题1.分布页面后，起始页从第二页开始了，第一页空白了，请问怎么修改从第一页开始分页？
2.如果没有选中对象，合并页面后，会造成整个页面假死，
第一个事件试试把s.MoveToLayer doc.Pages(pCou + 1).ActiveLayer这句改成s.MoveToLayer doc.Pages(（pCou-1） + 1).ActiveLayer试试看。第二个事件试试在on error goto er的er事件那里加入exit sub，或者修改一下是否有选中对象那里的判定，由对象数改成对象IS nothing，或者对象=“”，多尝试一下吧 jiangyu 发表于 2021-12-17 17:27
第一个事件试试把s.MoveToLayer doc.Pages(pCou + 1).ActiveLayer这句改成s.MoveToLayer doc.Pages(（pCou- ...
请问第一个事件，我加一句删除页面1，为什么会把后面的页面删除了
s.DeletePages (1) 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不会卡死了 终于找到我需要的代码,太感谢了!
页:
[1]