CorelDRAW VBA 拼版功能实现 — 物件排列拼版简单代码

剪贴板输入尺寸和拼版数量间隔，功能演示视频

arrange.bas 先来看 CorelDRAW 物件排列拼版简单代码

以下源码按设置的拼版距离实现按行3列4间隔3mm拼版, OrigSelection.StepAndRepeat方法在范围内创建当前选择的物件的多个副本。CreateShapeRangeFromArray 方法参数是 dup1, OrigSelection，就是把当前选择的物件和刚才建立的副本建立一个形状范围，然后再把这个范围再次向下建立更多的副本。

Sub arrange()

    ActiveDocument.Unit = cdrMillimeter
    Bleed = 2
    line_len = 3
    
    Size = 50   '尺寸 50x50mm
    sp = 3      '间隔 3mm
    row = 3     ' 拼版 3 x 4
    List = 4

    '// 当前选择物件 按行3列4间隔3mm拼版
    Dim OrigSelection As ShapeRange
    Set OrigSelection = ActiveSelectionRange
    
    '// StepAndRepeat 方法在范围内创建多个形状副本
    Dim dup1 As ShapeRange
    Set dup1 = OrigSelection.StepAndRepeat(row - 1, Size + sp, 0#)
    Dim dup2 As ShapeRange
    Set dup2 = ActiveDocument.CreateShapeRangeFromArray _
         (dup1, OrigSelection).StepAndRepeat(List - 1, 0#, -(Size + sp))
End Sub

拼版物件源码总体还是比较简单，为了实际工作需要，我们来建立剪贴板控制输入参数，完成更加灵活和方便的功能。

• GetClipBoardString 函数用来读取剪贴板文本，把其中的数字转换成程序的输入。
• CreateRectangle 使用第一组数字来画一个矩形 s1，然后 s1.StepAndRepeat(row - 1, sw + sp, 0#)建立副本，在陆续完成拼版功能。
• 如果剪贴板没有数字参数，代码会错误，所以使用 On Error GoTo ErrorHandler 转到错误处理，显示使用方法

'// CorelDRAW 物件排列拼版简单代码
Sub arrange()
    On Error GoTo ErrorHandler
    ActiveDocument.Unit = cdrMillimeter
    row = 3     ' 拼版 3 x 4
    List = 4
    sp = 0       '间隔 0mm
    
    Dim Str, arr, n
    Str = GetClipBoardString

    ' 替换 mm x * 换行 TAB 为空格
    Str = VBA.Replace(Str, "mm", " ")
    Str = VBA.Replace(Str, "x", " ")
    Str = VBA.Replace(Str, "*", " ")
    Str = VBA.Replace(Str, Chr(13), " ")
    Str = VBA.Replace(Str, Chr(9), " ")
    
    Do While InStr(Str, "  ") '多个空格换成一个空格
        Str = VBA.Replace(Str, "  ", " ")
    Loop
    
    arr = Split(Str)

    Dim x As Double
    Dim y As Double
    x = Val(arr(0))
    y = Val(arr(1))
    
    If UBound(arr) > 2 Then
    row = Val(arr(2))     ' 拼版 3 x 4
    List = Val(arr(3))
        If UBound(arr) > 3 Then
            sp = Val(arr(4))       '间隔
        End If
    End If
    
    Dim s1 As Shape
    '// 建立矩形 Width  x Height 单位 mm
    Set s1 = ActiveLayer.CreateRectangle(0, 0, x, y)
    
    '// 填充颜色无，轮廓颜色 K100，线条粗细0.3mm
    s1.Fill.ApplyNoFill
    s1.Outline.SetProperties 0.3, OutlineStyles(0), CreateCMYKColor(0, 100, 0, 0), ArrowHeads(0), _
        ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#

    sw = x
    sh = y
    
    '// StepAndRepeat 方法在范围内创建多个形状副本
    Dim dup1 As ShapeRange
    Set dup1 = s1.StepAndRepeat(row - 1, sw + sp, 0#)
    Dim dup2 As ShapeRange
    Set dup2 = ActiveDocument.CreateShapeRangeFromArray _
         (dup1, s1).StepAndRepeat(List - 1, 0#, (sh + sp))
         
    Exit Sub
ErrorHandler:
     MsgBox "记事本输入数字,示例: 50x50 4x3 ,复制到剪贴板再运行工具!"
    On Error Resume Next
End Sub

Private Function GetClipBoardString() As String
    On Error Resume Next
    Dim MyData As New DataObject
    GetClipBoardString = ""
    MyData.GetFromClipboard
    GetClipBoardString = MyData.GetText
    Set MyData = Nothing
End Function