1
1

ModulePlus.bas 2.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109
  1. Attribute VB_Name = "ModulePlus"
  2. '// 断开所有节点 分割线段
  3. Public Function SplitSegment()
  4. On Error GoTo ErrorHandler
  5. API.BeginOpt
  6. Dim ssr As ShapeRange, s As Shape
  7. Dim nr As NodeRange, nd As Node
  8. Set ssr = ActiveSelectionRange
  9. Set s = ssr.UngroupAllEx.Combine
  10. Set nr = s.Curve.Nodes.all
  11. nr.BreakApart
  12. s.BreakApartEx
  13. ErrorHandler:
  14. API.EndOpt
  15. End Function
  16. '// 批量正方形 宽高统一
  17. Public Function square_hw(Optional ByVal hw As String = "Height")
  18. API.BeginOpt
  19. Set os = ActiveSelectionRange
  20. Set ss = os.Shapes
  21. For Each s In ss
  22. If hw = "Height" Then s.SizeWidth = s.SizeHeight
  23. If hw = "Width" Then s.SizeHeight = s.SizeWidth
  24. Next s
  25. API.EndOpt
  26. End Function
  27. '// 节点优化减少
  28. Public Function Nodes_Reduce()
  29. On Error GoTo ErrorHandler: API.BeginOpt
  30. Set doc = ActiveDocument
  31. Dim s As Shape
  32. ps = Array(1)
  33. doc.Unit = cdrTenthMicron
  34. Set os = ActivePage.Shapes
  35. If os.Count > 0 Then
  36. For Each s In os
  37. s.ConvertToCurves
  38. If Not s.DisplayCurve Is Nothing Then
  39. s.Curve.AutoReduceNodes 50
  40. End If
  41. Next s
  42. End If
  43. ErrorHandler:
  44. API.EndOpt
  45. End Function
  46. '// 标注线 选择文字 删除等
  47. Public Function Dimension_Select_or_Delete(Shift As Long)
  48. On Error GoTo ErrorHandler: API.BeginOpt
  49. Dim os As ShapeRange, sr As ShapeRange, s As Shape
  50. Set doc = ActiveDocument
  51. Set sr = ActiveSelectionRange
  52. sr.RemoveAll
  53. If Shift = 4 Then
  54. Set os = ActiveSelectionRange
  55. For Each s In os.Shapes
  56. If s.Type = cdrTextShape Then sr.Add s
  57. Next s
  58. sr.CreateSelection
  59. ElseIf Shift = 1 Then
  60. Set os = ActiveSelectionRange
  61. For Each s In os.Shapes
  62. If s.Type = cdrLinearDimensionShape Then sr.Add s
  63. Next s
  64. sr.CreateSelection
  65. ElseIf Shift = 2 Then
  66. Set os = ActiveSelectionRange
  67. For Each s In os.Shapes
  68. If s.Type = cdrLinearDimensionShape Then sr.Add s
  69. Next s
  70. sr.Delete
  71. If os.Count > 0 Then
  72. os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
  73. ActiveSelectionRange.Delete
  74. End If
  75. End If
  76. ErrorHandler:
  77. API.EndOpt
  78. End Function
  79. '// 解绑尺寸,分离尺寸
  80. Public Function Untie_MarkLines()
  81. On Error GoTo ErrorHandler: API.BeginOpt
  82. Dim os As ShapeRange, dss As New ShapeRange
  83. Set os = ActiveSelectionRange
  84. For Each s In os.Shapes
  85. If s.Type = cdrLinearDimensionShape Then
  86. dss.Add s
  87. End If
  88. Next s
  89. If dss.Count > 0 Then
  90. dss.BreakApartEx
  91. os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
  92. ActiveSelectionRange.Delete
  93. End If
  94. ErrorHandler:
  95. API.EndOpt
  96. End Function