CorelDRAW VBA 简单代码实现实用用工具-傻瓜火车排列

CorelDRAW 好像没有多个物件的对准排列，工作中又经常用到，所以写了个简单代码

Sub 傻瓜火车排列()
  ActiveDocument.ReferencePoint = cdrBottomLeft  '// 设置对准基准 左下
  Dim ssr As ShapeRange, s As Shape     '// 定义选择物件数组 ssr， 和遍历物件 s
  Dim cnt As Integer                    '// 定义物件个数计数器
  Set ssr = ActiveSelectionRange
  cnt = 1
  
  For Each s In ssr
    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX + ssr(cnt - 1).SizeWidth, ssr(cnt - 1).BottomY
    cnt = cnt + 1
  Next s

End Sub

代码还可以继续优化和改写成两种方向排列: 火车排列(行) 和 阶梯排列(竖)

Sub 傻瓜火车排列()
  Dim ssr As ShapeRange, s As Shape
  Dim cnt As Integer
  Set ssr = ActiveSelectionRange
  cnt = 1
  
  ActiveDocument.ReferencePoint = cdrBottomLeft
  For Each s In ssr
    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
    cnt = cnt + 1
  Next s

End Sub

Sub 傻瓜阶梯排列()
  Dim ssr As ShapeRange, s As Shape
  Dim cnt As Integer
  Set ssr = ActiveSelectionRange
  cnt = 1
  
  ActiveDocument.ReferencePoint = cdrTopLeft
  For Each s In ssr
    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY
    cnt = cnt + 1
  Next s

End Sub

CorelDRAW X5 以上支持 ShapeRange 物件 通过CQL查询尺寸和坐标，使用 Sort 方法排序

Public Function 傻瓜火车排列()
  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
  Dim ssr As ShapeRange, s As Shape
  Dim cnt As Integer
  Set ssr = ActiveSelectionRange
  cnt = 1

#If VBA7 Then
'  ssr.sort " @shape1.top>@shape2.top"
  ssr.Sort " @shape1.left<@shape2.left"
#Else
' X4 不支持 ShapeRange.sort
#End If

  ActiveDocument.ReferencePoint = cdrBottomLeft
  For Each s In ssr
    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
    cnt = cnt + 1
  Next s

  ActiveDocument.EndCommandGroup
  Application.Optimization = False
  ActiveWindow.Refresh:    Application.Refresh
End Function


Public Function 傻瓜阶梯排列()
  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
  Dim ssr As ShapeRange, s As Shape
  Dim cnt As Integer
  Set ssr = ActiveSelectionRange
  cnt = 1

#If VBA7 Then
  ssr.Sort " @shape1.top>@shape2.top"
'  ssr.sort " @shape1.left<@shape2.left"
#Else
' X4 不支持 ShapeRange.sort
#End If

  ActiveDocument.ReferencePoint = cdrTopLeft
  For Each s In ssr
    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY
    cnt = cnt + 1
  Next s

  ActiveDocument.EndCommandGroup
  Application.Optimization = False
  ActiveWindow.Refresh:    Application.Refresh
End Function

个人主要用CorelDRAW X4 做些辅助手工拼版，找不到好的方法排序

'// 获得数组元素个数
Public Function arrlen(src As Variant) As Integer
  On Error Resume Next '空意味着 0 长度
  arrlen = (UBound(src) - LBound(src))
End Function

'// 对数组进行排序[单维]
Public Function ArraySort(src As Variant) As Variant
  Dim out As Long, i As Long, tmp As Variant
  For out = LBound(src) To UBound(src) - 1
    For i = out + 1 To UBound(src)
      If src(out) > src(i) Then
        tmp = src(i): src(i) = src(out): src(out) = tmp
      End If
    Next i
  Next out
  
  ArraySort = src
End Function

'// 测试数组排序
Private test_ArraySort()
  Dim arr As Variant, i As Integer
  arr = Array(5, 4, 3, 2, 1, 9, 999, 33)
  For i = 0 To arrlen(arr) - 1
    Debug.Print arr(i);
  Next i
  Debug.Print arrlen(arr)
  ArraySort arr
  For i = 0 To arrlen(arr) - 1
    Debug.Print arr(i);
  Next i
End Sub