corelvba/module/ModulePlus.bas

Attribute VB_Name = "ModulePlus"
'// 断开所有节点 分割线段
Public Function SplitSegment()
  On Error GoTo ErrorHandler
  API.BeginOpt
  Dim ssr As ShapeRange, s As Shape
  Dim nr As NodeRange, nd As Node
  
  Set ssr = ActiveSelectionRange
  Set s = ssr.UngroupAllEx.Combine
  Set nr = s.Curve.Nodes.all
  
  nr.BreakApart
  s.BreakApartEx
  
ErrorHandler:
  API.EndOpt
End Function

'// 批量正方形 宽高统一
Public Function square_hw(Optional ByVal hw As String = "Height")
  API.BeginOpt
  Set os = ActiveSelectionRange
  Set ss = os.Shapes
  For Each s In ss
    If hw = "Height" Then s.SizeWidth = s.SizeHeight
    If hw = "Width" Then s.SizeHeight = s.SizeWidth
  Next s
  API.EndOpt
End Function

'// 节点优化减少
Public Function Nodes_Reduce()
  On Error GoTo ErrorHandler: API.BeginOpt
  Set doc = ActiveDocument
  Dim s As Shape
  ps = Array(1)
  doc.Unit = cdrTenthMicron
  Set os = ActivePage.Shapes
  If os.Count > 0 Then
    For Each s In os
    s.ConvertToCurves
      If Not s.DisplayCurve Is Nothing Then
        s.Curve.AutoReduceNodes 50
      End If
    Next s
  End If
ErrorHandler:
  API.EndOpt
End Function

'// 标注线 选择文字 删除等
Public Function Dimension_Select_or_Delete(Shift As Long)
  On Error GoTo ErrorHandler: API.BeginOpt
  Dim os As ShapeRange, sr As ShapeRange, s As Shape
  Set doc = ActiveDocument
  Set sr = ActiveSelectionRange
  sr.RemoveAll

  If Shift = 4 Then
    Set os = ActiveSelectionRange
    For Each s In os.Shapes
      If s.Type = cdrTextShape Then sr.Add s
    Next s
  sr.CreateSelection
  
  ElseIf Shift = 1 Then
    Set os = ActiveSelectionRange
    For Each s In os.Shapes
      If s.Type = cdrLinearDimensionShape Then sr.Add s
    Next s
    sr.CreateSelection
    
  ElseIf Shift = 2 Then
    Set os = ActiveSelectionRange
    For Each s In os.Shapes
      If s.Type = cdrLinearDimensionShape Then sr.Add s
    Next s
    sr.Delete
    If os.Count > 0 Then
      os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
      ActiveSelectionRange.Delete
    End If
  End If
  
ErrorHandler:
  API.EndOpt
End Function

'// 解绑尺寸，分离尺寸
Public Function Untie_MarkLines()
  On Error GoTo ErrorHandler: API.BeginOpt
  
  Dim os As ShapeRange, dss As New ShapeRange
  Set os = ActiveSelectionRange
  For Each s In os.Shapes
      If s.Type = cdrLinearDimensionShape Then
        dss.Add s
      End If
  Next s
  If dss.Count > 0 Then
    dss.BreakApartEx
    os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
    ActiveSelectionRange.Delete
  End If
  
ErrorHandler:
  API.EndOpt
End Function