1
1

Arrange.bas 2.8 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889
  1. Attribute VB_Name = "Arrange"
  2. '// This is free and unencumbered software released into the public domain.
  3. '// For more information, please refer to https://github.com/hongwenjun
  4. '// Attribute VB_Name = "物件排列拼版" Arrange 2023.12.20
  5. '// CorelDRAW 物件排列拼版简单代码
  6. Public Function Arrange()
  7. On Error GoTo ErrorHandler
  8. #If VBA7 Then
  9. API.BeginOpt
  10. #Else
  11. '// CorelDRAW X4 刷新缓冲区有问题
  12. ActiveDocument.Unit = cdrMillimeter
  13. #End If
  14. row = 3 ' 拼版 3 x 4
  15. List = 4
  16. sp = 0 '间隔 0mm
  17. Dim str, arr, n
  18. str = API.GetClipBoardString
  19. ' 替换 mm x * 换行 TAB 为空格
  20. str = VBA.Replace(str, "mm", " ")
  21. str = VBA.Replace(str, "x", " ")
  22. str = VBA.Replace(str, "X", " ")
  23. str = VBA.Replace(str, "*", " ")
  24. '// 换行转空格 多个空格换成一个空格
  25. str = API.Newline_to_Space(str)
  26. arr = Split(str)
  27. Dim s1 As Shape
  28. Dim X As Double, Y As Double
  29. If 0 = ActiveSelectionRange.Count Then
  30. X = Val(arr(0)): Y = Val(arr(1))
  31. row = Int(ActiveDocument.Pages.First.SizeWidth / X)
  32. List = Int(ActiveDocument.Pages.First.SizeHeight / Y)
  33. If UBound(arr) > 2 Then
  34. row = Val(arr(2)): List = Val(arr(3))
  35. If row * List > 8000 Then
  36. GoTo ErrorHandler
  37. ElseIf UBound(arr) > 3 Then
  38. sp = Val(arr(4)) '间隔
  39. End If
  40. End If
  41. '// 建立矩形 Width x Height 单位 mm
  42. Set s1 = ActiveLayer.CreateRectangle(0, 0, X, Y)
  43. '// 填充颜色无,轮廓颜色 K100,线条粗细0.3mm
  44. s1.Fill.ApplyNoFill
  45. s1.Outline.SetProperties 0.3, OutlineStyles(0), CreateCMYKColor(0, 100, 0, 0), ArrowHeads(0), _
  46. ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#
  47. '// 如果当前选择物件,按当前物件拼版
  48. ElseIf 0 < ActiveSelectionRange.Count Then
  49. Set s1 = ActiveSelection
  50. X = s1.SizeWidth: Y = s1.SizeHeight
  51. row = Int(ActiveDocument.Pages.First.SizeWidth / X)
  52. List = Int(ActiveDocument.Pages.First.SizeHeight / Y)
  53. End If
  54. sw = X: sh = Y
  55. '// StepAndRepeat 方法在范围内创建多个形状副本
  56. Dim dup1 As ShapeRange, dup2 As ShapeRange
  57. If row > 1 Then
  58. Set dup1 = s1.StepAndRepeat(row - 1, sw + sp, 0#)
  59. If List > 1 Then Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(List - 1, 0#, (sh + sp))
  60. End If
  61. If List > 1 And row < 2 Then Set dup1 = s1.StepAndRepeat(List - 1, 0#, (sh + sp))
  62. ErrorHandler:
  63. API.EndOpt
  64. End Function
  65. '***************** 之前旧的代码 不能处理 row 和 list 等于1 的 **********************
  66. ' Dim dup1 As ShapeRange
  67. ' Set dup1 = s1.StepAndRepeat(row - 1, sw + sp, 0#)
  68. ' Dim dup2 As ShapeRange
  69. ' Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(List - 1, 0#, (sh + sp))