- 精华
- 活跃值
-
- 积分
- 3423
- 违规
-
- 印币
-
- 鲜花值
-
- 在线时间
- 小时
累计签到:184 天 连续签到:2 天
|
从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.如果没有选中对象,合并页面后,会造成整个页面假死,
|
|