1
1

ClipbRectangle.bas 3.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110
  1. Attribute VB_Name = "ClipbRectangle"
  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 = "剪贴板尺寸建立矩形" Clipboard Size Build Rectangle 2023.6.11
  5. Type Coordinate
  6. X As Double
  7. Y As Double
  8. End Type
  9. Public O_O As Coordinate
  10. Public Function Build_Rectangle()
  11. '// 坐标原点
  12. O_O.X = 0: O_O.Y = 0
  13. Dim ost As ShapeRange
  14. Set ost = ActiveSelectionRange
  15. O_O.X = ost.LeftX
  16. O_O.Y = ost.BottomY - 50 '// 选择物件 下移动 50mm
  17. '// 建立矩形 Width x Height 单位 mm
  18. Dim str, arr, n
  19. str = API.GetClipBoardString
  20. '// 替换 mm x * 换行 TAB 为空格
  21. str = VBA.Replace(str, "m", " ")
  22. str = VBA.Replace(str, "x", " ")
  23. str = VBA.Replace(str, "X", " ")
  24. str = VBA.Replace(str, "*", " ")
  25. str = VBA.Replace(str, vbNewLine, " ")
  26. Do While InStr(str, " ") '// 多个空格换成一个空格
  27. str = VBA.Replace(str, " ", " ")
  28. Loop
  29. arr = Split(str)
  30. API.BeginOpt
  31. Dim X As Double
  32. Dim Y As Double
  33. For n = LBound(arr) To UBound(arr) - 1 Step 2
  34. X = Val(arr(n))
  35. Y = Val(arr(n + 1))
  36. If X > 0 And Y > 0 Then
  37. Rectangle X, Y
  38. O_O.X = O_O.X + X + 30
  39. End If
  40. Next
  41. API.EndOpt
  42. End Function
  43. '// 建立矩形 Width x Height 单位 mm
  44. Private Function Rectangle(width As Double, Height As Double)
  45. ActiveDocument.Unit = cdrMillimeter
  46. Dim size As Shape
  47. Dim d As Document
  48. Dim s1 As Shape
  49. '// 建立矩形 Width x Height 单位 mm
  50. Set s1 = ActiveLayer.CreateRectangle(O_O.X, O_O.Y, O_O.X + width, O_O.Y - Height)
  51. '// 填充颜色无,轮廓颜色 K100,线条粗细0.3mm
  52. s1.Fill.ApplyNoFill
  53. s1.Outline.SetProperties 0.3, OutlineStyles(0), CreateCMYKColor(0, 100, 0, 0), ArrowHeads(0), ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#
  54. sw = s1.SizeWidth
  55. sh = s1.SizeHeight
  56. text = Trim(str(sw)) + "x" + Trim(str(sh)) + "mm"
  57. Set d = ActiveDocument
  58. Set size = d.ActiveLayer.CreateArtisticText(O_O.X + sw / 2 - 25, O_O.Y + 10, text, Font:="Tahoma") '// O_O.y + 10 标注尺寸上移 10mm
  59. size.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
  60. End Function
  61. '// 测试矩形变形
  62. Private Function setRectangle(width As Double, Height As Double)
  63. Dim s1 As Shape
  64. Set s1 = ActiveSelection
  65. ActiveDocument.Unit = cdrMillimeter
  66. '// 物件中心基准, 先把宽度设定为
  67. ActiveDocument.ReferencePoint = cdrCenter
  68. s1.SetSize Height, Height
  69. '// 物件旋转 30度,轮廓线1mm ,轮廓颜色 M100Y100
  70. s1.Rotate 30#
  71. s1.Outline.SetProperties 1#
  72. s1.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 100, 0)
  73. End Function
  74. '// 获得选择物件大小信息
  75. Public Function get_all_size()
  76. ActiveDocument.Unit = cdrMillimeter
  77. Set fs = CreateObject("Scripting.FileSystemObject")
  78. Set f = fs.CreateTextFile("R:\size.txt", True)
  79. Dim sh As Shape, shs As Shapes
  80. Set shs = ActiveSelection.Shapes
  81. Dim s As String
  82. For Each sh In shs
  83. size = Trim(str(Int(sh.SizeWidth + 0.5))) + "x" + Trim(str(Int(sh.SizeHeight + 0.5))) + "mm"
  84. f.WriteLine (size)
  85. s = s + size + vbNewLine
  86. Next sh
  87. f.Close
  88. MsgBox "输出物件尺寸信息到文件" & "R:\size.txt" & vbNewLine & s
  89. API.WriteClipBoard s
  90. End Function