1
1

ClipboardRectangle.bas 2.8 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495
  1. '// Attribute VB_Name = "剪贴板尺寸建立矩形"
  2. Type Coordinate
  3. x As Double
  4. y As Double
  5. End Type
  6. Public O_O As Coordinate
  7. Sub start()
  8. '// 坐标原点
  9. O_O.x = 0: O_O.y = 0
  10. Dim ost As ShapeRange
  11. Set ost = ActiveSelectionRange
  12. O_O.x = ost.LeftX
  13. O_O.y = ost.BottomY - 50 '选择物件 下移动 50mm
  14. '// 建立矩形 Width x Height 单位 mm
  15. ' Rectangle 101, 151
  16. Dim Str, arr, n
  17. Str = GetClipBoardString
  18. ' 替换 mm x * 换行 TAB 为空格
  19. Str = VBA.Replace(Str, "mm", " ")
  20. Str = VBA.Replace(Str, "x", " ")
  21. Str = VBA.Replace(Str, "*", " ")
  22. Str = VBA.Replace(Str, Chr(13), " ")
  23. Str = VBA.Replace(Str, Chr(9), " ")
  24. Do While InStr(Str, " ") '多个空格换成一个空格
  25. Str = VBA.Replace(Str, " ", " ")
  26. Loop
  27. arr = Split(Str)
  28. ActiveDocument.BeginCommandGroup '一步撤消'
  29. Dim x As Double
  30. Dim y As Double
  31. For n = LBound(arr) To UBound(arr) - 1 Step 2
  32. ' MsgBox arr(n)
  33. x = Val(arr(n))
  34. y = Val(arr(n + 1))
  35. If x > 0 And y > 0 Then
  36. Rectangle x, y
  37. O_O.x = O_O.x + x + 30
  38. End If
  39. Next
  40. ActiveDocument.EndCommandGroup
  41. End Sub
  42. Private Function Rectangle(Width As Double, Height As Double)
  43. ActiveDocument.Unit = cdrMillimeter
  44. Dim size As Shape
  45. Dim d As Document
  46. Dim s1 As Shape
  47. '// 建立矩形 Width x Height 单位 mm
  48. Set s1 = ActiveLayer.CreateRectangle(O_O.x, O_O.y, O_O.x + Width, O_O.y - Height)
  49. '// 填充颜色无,轮廓颜色 K100,线条粗细0.3mm
  50. s1.Fill.ApplyNoFill
  51. s1.Outline.SetProperties 0.3, OutlineStyles(0), CreateCMYKColor(0, 100, 0, 0), ArrowHeads(0), ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#
  52. sw = s1.SizeWidth
  53. sh = s1.SizeHeight
  54. Text = Trim(Str(sw)) + "x" + Trim(Str(sh)) + "mm"
  55. Set d = ActiveDocument
  56. Set size = d.ActiveLayer.CreateArtisticText(O_O.x + sw / 2 - 25, O_O.y + 10, Text) '// O_O.y + 10 标注尺寸上移 10mm
  57. size.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
  58. End Function
  59. Private Function setRectangle(Width As Double, Height As Double)
  60. Dim s1 As Shape
  61. Set s1 = ActiveSelection
  62. ActiveDocument.Unit = cdrMillimeter
  63. '// 物件中心基准, 先把宽度设定为
  64. ActiveDocument.ReferencePoint = cdrCenter
  65. s1.SetSize Height, Height
  66. '// 物件旋转 30度,轮廓线1mm ,轮廓颜色 M100Y100
  67. s1.Rotate 30#
  68. s1.Outline.SetProperties 1#
  69. s1.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 100, 0)
  70. End Function
  71. Private Function GetClipBoardString() As String
  72. On Error Resume Next
  73. Dim MyData As New DataObject
  74. GetClipBoardString = ""
  75. MyData.GetFromClipboard
  76. GetClipBoardString = MyData.GetText
  77. Set MyData = Nothing
  78. End Function