QQ登录

只需一步,快速开始

查看: 7668|回复: 4
收起左侧

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

[复制链接]
累计签到:184 天
连续签到:2 天
发表于 2021-12-17 15:23:42 | 显示全部楼层 |阅读模式
从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. Function EndOpt()
  15.     ActiveDocument.PreserveSelection = True
  16.     ActiveDocument.RestoreSettings
  17.     EventsEnabled = True
  18.     Optimization = False
  19.     Application.Refresh
  20.     Application.CorelScript.RedrawScreen
  21.     ActiveDocument.EndCommandGroup
  22.     Beep
  23. End Function

  24. Sub 分布页面()
  25. Dim doc As Document, s As Shape, n As Integer, sCnut As Integer
  26. Dim Size_x As Double, Size_y As Double, dInd As Integer, pCou As Integer
  27. On Error GoTo Er

  28.     Set doc = ActiveDocument
  29.     If Documents.Count = 0 Then MsgBox "没有文件被打开。": Exit Sub
  30.     If doc.Selection.Shapes.Count = 0 Then MsgBox "请选择一个或多个分布对象。": Exit Sub
  31.     BeginOpt "分布页面"
  32.    
  33.     doc.ActivePage.GetSize Size_x, Size_y
  34.     pCou = doc.Pages.Count
  35.     dInd = doc.ActivePage.Index
  36.    
  37.     For Each s In ActiveSelectionRange()
  38.         doc.InsertPagesEx 1, 0, pCou, Size_x, Size_y
  39.         s.MoveToLayer doc.Pages(pCou + 1).ActiveLayer
  40.         If Application.VersionMajor > 15 Then _
  41.         s.AlignAndDistribute 3, 3, 1, 0, 0, 2 Else s.AlignToPageCenter 15, 2
  42.     Next s

  43.     doc.Pages(dInd).Activate
  44. Er: EndOpt
  45.    
  46. End Sub

  47. Sub 合并页面()
  48. Dim doc As Document, sr As ShapeRange, dInd As Integer, pCou As Integer, n As Integer
  49. Dim Size_x As Double, Size_y As Double, nCol As Double, nRow As Double, x As Integer, y As Integer
  50. On Error GoTo Er

  51.     Set doc = ActiveDocument
  52.     If Documents.Count = 0 Then MsgBox "没有文件被打开。": Exit Sub
  53.     If doc.Selection.Shapes.Count = 0 Then MsgBox "请选择当前页的合并对象,拼版将使用它的尺寸。": Exit Sub
  54.    
  55.     BeginOpt "合并页面"
  56.    
  57.     ActiveSelectionRange.GetSize Size_x, Size_y
  58.     pCou = doc.Pages.Count
  59.     dInd = doc.ActivePage.Index
  60.     If pCou < 1 Or pCou - dInd < 1 Then MsgBox "起始页之后没有可合并的页面。": Exit Sub
  61.   
  62. Re: nCol = InputBox(vbCrLf & "  请告诉我你要排成几列?", "合并页面_LinSong", Round(Sqr(pCou - dInd + 1)))

  63.         If nCol > 0 And nCol < (pCou - dInd + 1) Then
  64.             nRow = IIf((pCou - dInd + 1) / nCol > Round((pCou - dInd + 1) / nCol), _
  65.             Round((pCou - dInd + 1) / nCol) + 1, Round((pCou - dInd + 1) / nCol))
  66.         Else
  67.             MsgBox "输入的数值超出了可操作页数范围,请重新输入。": GoTo Re
  68.         End If

  69.    doc.DrawingOriginX = Size_x
  70.     doc.DrawingOriginY = Size_y
  71.    
  72.     x = 1: y = nRow
  73.     For n = 0 To pCou - dInd
  74.         Set sr = doc.CreateShapeRangeFromArray(doc.Pages(dInd + n).Shapes.All)
  75.             sr.RemoveRange doc.Pages(All).DesktopLayer.Shapes.All
  76.             sr.RemoveRange doc.Pages(All).GuidesLayer.Shapes.All
  77.             sr.Group
  78.             sr.MoveToLayer doc.Pages(dInd).ActiveLayer
  79.         If x > nCol Then y = y - 1: x = 1
  80.         sr.SetPosition Size_x * (x - 1), Size_y * y: x = x + 1
  81.     Next n
  82.    doc.DeletePages dInd + 1, pCou - dInd
  83. Er: EndOpt
  84.    
  85. End Sub
复制代码

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

华印网相关搜索

累计签到:1633 天
连续签到:4 天
发表于 2021-12-17 17:27:48 | 显示全部楼层
第一个事件试试把s.MoveToLayer doc.Pages(pCou + 1).ActiveLayer这句改成s.MoveToLayer doc.Pages((pCou-1) + 1).ActiveLayer试试看。第二个事件试试在on error goto er的er事件那里加入exit sub,或者修改一下是否有选中对象那里的判定,由对象数改成对象IS nothing,或者对象=“”,多尝试一下吧
回复 支持 反对 送花

使用道具 举报

累计签到:184 天
连续签到:2 天
 楼主| 发表于 2021-12-17 21:04:48 | 显示全部楼层
jiangyu 发表于 2021-12-17 17:27
第一个事件试试把s.MoveToLayer doc.Pages(pCou + 1).ActiveLayer这句改成s.MoveToLayer doc.Pages((pCou- ...

请问第一个事件,我加一句删除页面1,为什么会把后面的页面删除了
s.DeletePages (1)
回复 支持 反对 送花

使用道具 举报

累计签到:184 天
连续签到:2 天
 楼主| 发表于 2021-12-18 09:39:43 | 显示全部楼层
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不会卡死了
回复 支持 反对 送花

使用道具 举报

累计签到:120 天
连续签到:8 天
发表于 2024-6-21 10:43:02 | 显示全部楼层
终于找到我需要的代码,太感谢了!
回复 支持 反对 送花

使用道具 举报

您需要登录后才可以回帖 登录 | 注册帐号

本版积分规则

关闭

注意注意注意:必看上一条 /1 下一条

华印网 - 华印社区
Share More 周一至周日:09:00 - 21:00
华印网旗下的设计印刷制作类专业技术站点
请勿发布违反国家法律法规的内容,会员观点不代表本站立场
企鹅群号:119572101

华印网汇集印前印后技术、PDF拼版、防伪包装、数码印刷、合版印刷、图文设计、平面设计、数码印刷及CTP等最新印刷技术,提供软件汉化、插件汉化、cdr插件、ai插件、ps插件、pdf插件、印刷流程、ctp输出、印刷软件、印能捷、esko、CorelDRAW、InDesign、Illustrator、CTP、CDR以及PDF软件下载的综合性印刷论坛社区!

Powered by Discuz! X3.4 © 2001-2021,Tencent Cloud.

站点地图|小黑屋|手机版|Archiver|华印 ( 粤ICP备19020152号-1 )

GMT+8, 2024-11-1 07:11 , Processed in 0.076389 second(s), 24 queries , Gzip On, Yac On.

快速回复 返回顶部 返回列表