ArrangeForm.frm 2.4 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788
  1. VERSION 5.00
  2. Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ArrangeForm
  3. Caption = "蘭雅sRGB 手动拼版 │ 嘉盟赞助"
  4. ClientHeight = 2475
  5. ClientLeft = 45
  6. ClientTop = 330
  7. ClientWidth = 4650
  8. OleObjectBlob = "ArrangeForm.frx":0000
  9. ShowModal = 0 'False
  10. StartUpPosition = 2 'CenterScreen
  11. WhatsThisButton = -1 'True
  12. WhatsThisHelp = -1 'True
  13. End
  14. Attribute VB_Name = "ArrangeForm"
  15. Attribute VB_GlobalNameSpace = False
  16. Attribute VB_Creatable = False
  17. Attribute VB_PredeclaredId = True
  18. Attribute VB_Exposed = False
  19. Private Sub CommandButton1_Click()
  20. On Error GoTo ErrorHandler
  21. ActiveDocument.Unit = cdrMillimeter
  22. Dim ls As Integer, hs As Integer
  23. Dim lj As Double, hj As Double
  24. Dim matrix As Variant
  25. Dim s As ShapeRange
  26. ls = Val(TextBox1.text)
  27. hs = Val(TextBox2.text)
  28. lj = Val(TextBox3.text)
  29. hj = Val(TextBox4.text)
  30. matrix = Array(ls, hs, lj, hj)
  31. Set s = ActiveSelectionRange
  32. If ls * hs = 0 Then Exit Sub
  33. If ls = 1 Or hs = 1 Then
  34. arrange_Clone_one matrix, s
  35. Exit Sub
  36. End If
  37. '// 代码运行时关闭窗口刷新
  38. ActiveDocument.BeginCommandGroup: Application.Optimization = True
  39. '// 拼版矩阵
  40. arrange_Clone matrix, s
  41. ActiveDocument.EndCommandGroup
  42. Unload Me
  43. '// 代码操作结束恢复窗口刷新
  44. ActiveDocument.EndCommandGroup
  45. Application.Optimization = False
  46. ActiveWindow.Refresh: Application.Refresh
  47. Exit Sub
  48. ErrorHandler:
  49. Application.Optimization = False
  50. On Error Resume Next
  51. End Sub
  52. '// 拼版矩阵 matrix = Array(ls,hs,lj,hj)
  53. Private Function arrange_Clone(matrix As Variant, s As ShapeRange)
  54. ls = matrix(0): hs = matrix(1)
  55. lj = matrix(2): hj = matrix(3)
  56. x = s.SizeWidth: Y = s.SizeHeight
  57. Set s1 = s.Clone
  58. '// StepAndRepeat 方法在范围内创建多个形状副本
  59. Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
  60. Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(Y + hj))
  61. s1.Delete
  62. End Function
  63. Private Function arrange_Clone_one(matrix As Variant, s As ShapeRange)
  64. ls = matrix(0): hs = matrix(1)
  65. lj = matrix(2): hj = matrix(3)
  66. x = s.SizeWidth: Y = s.SizeHeight
  67. Set s1 = s.Clone
  68. '// StepAndRepeat 方法在范围内创建多个形状副本
  69. If ls > 1 Then
  70. Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
  71. Else
  72. Set dup1 = s1
  73. End If
  74. If hs > 1 Then
  75. Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(Y + hj))
  76. End If
  77. s1.Delete
  78. End Function