1
1

arrange.bas 2.1 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768
  1. '// CorelDRAW 物件排列拼版简单代码
  2. Sub arrange()
  3. On Error GoTo ErrorHandler
  4. ActiveDocument.Unit = cdrMillimeter
  5. row = 3 ' 拼版 3 x 4
  6. List = 4
  7. sp = 0 '间隔 0mm
  8. Dim Str, arr, n
  9. Str = GetClipBoardString
  10. ' 替换 mm x * 换行 TAB 为空格
  11. Str = VBA.Replace(Str, "mm", " ")
  12. Str = VBA.Replace(Str, "x", " ")
  13. Str = VBA.Replace(Str, "*", " ")
  14. Str = VBA.Replace(Str, Chr(13), " ")
  15. Str = VBA.Replace(Str, Chr(9), " ")
  16. Do While InStr(Str, " ") '多个空格换成一个空格
  17. Str = VBA.Replace(Str, " ", " ")
  18. Loop
  19. arr = Split(Str)
  20. Dim x As Double, y As Double
  21. x = Val(arr(0)): y = Val(arr(1))
  22. row = Int(ActiveDocument.Pages.First.SizeWidth / x)
  23. List = Int(ActiveDocument.Pages.First.SizeHeight / y)
  24. If UBound(arr) > 2 Then
  25. row = Val(arr(2)): List = Val(arr(3))
  26. If UBound(arr) > 3 Then
  27. sp = Val(arr(4)) '间隔
  28. End If
  29. End If
  30. Dim s1 As Shape
  31. '// 建立矩形 Width x Height 单位 mm
  32. Set s1 = ActiveLayer.CreateRectangle(0, 0, x, y)
  33. '// 填充颜色无,轮廓颜色 K100,线条粗细0.3mm
  34. s1.Fill.ApplyNoFill
  35. s1.Outline.SetProperties 0.3, OutlineStyles(0), CreateCMYKColor(0, 100, 0, 0), ArrowHeads(0), _
  36. ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#
  37. sw = x: sh = y
  38. '// StepAndRepeat 方法在范围内创建多个形状副本
  39. Dim dup1 As ShapeRange
  40. Set dup1 = s1.StepAndRepeat(row - 1, sw + sp, 0#)
  41. Dim dup2 As ShapeRange
  42. Set dup2 = ActiveDocument.CreateShapeRangeFromArray _
  43. (dup1, s1).StepAndRepeat(List - 1, 0#, (sh + sp))
  44. Exit Sub
  45. ErrorHandler:
  46. MsgBox "记事本输入数字,示例: 50x50 4x3 ,复制到剪贴板再运行工具!"
  47. On Error Resume Next
  48. End Sub
  49. Private Function GetClipBoardString() As String
  50. On Error Resume Next
  51. Dim MyData As New DataObject
  52. GetClipBoardString = ""
  53. MyData.GetFromClipboard
  54. GetClipBoardString = MyData.GetText
  55. Set MyData = Nothing
  56. End Function