vbabox/lines.bas

Attribute VB_Name = "lines"
'// 代码写到这里吧，视频结束
Sub start()
  LinesForm.Show 0
End Sub

Public Function Nodes_DrawLines()
  On Error GoTo ErrorHandler
  API.BeginOpt
  Dim sr As ShapeRange, sr_tmp As New ShapeRange, sr_lines As New ShapeRange
  Dim s As Shape, sh As Shape
  Dim nr As NodeRange
  Set sr = ActiveSelectionRange
  If sr.Count = 0 Then Exit Function
  
  For Each sh In sr
    Set nr = sh.Curve.Selection
    If nr.Count > 0 Then
      For Each n In nr
        Set s = ActiveLayer.CreateEllipse2(n.PositionX, n.PositionY, 0.5, 0.5)
        sr_tmp.Add s
      Next n
    End If
  Next sh
  
  '// 没有选择节点的情况，使用物件中心划线
  If sr_tmp.Count < 2 And sr.Count > 1 Then
    Set Line = DrawLine(sr(1), sr(2))
    sr_lines.Add Line
  End If
  
  sr_tmp.Sort "@shape1.left < @shape2.left"
  
  '// 使用 Count 遍历 shaperange 这种情况方便点
  For i = 1 To sr_tmp.Count - 1
    Set Line = DrawLine(sr_tmp(i), sr_tmp(i + 1))
    sr_lines.Add Line
  Next
  
  sr_tmp.Delete
  sr_lines.CreateSelection
ErrorHandler:
  API.EndOpt
End Function


Public Function Draw_Multiple_Lines(hv As cdrAlignType)
  On Error GoTo ErrorHandler
  API.BeginOpt
  Dim sr As ShapeRange, sr_lines As New ShapeRange
  Set sr = ActiveSelectionRange
  
  If sr.Count < 2 Then Exit Function
  
  If hv = cdrAlignVCenter Then
    '// 从左到右排序
    sr.Sort "@shape1.left < @shape2.left"
  ElseIf hv = cdrAlignHCenter Then
    '// 从上到下排序
    sr.Sort "@shape1.top < @shape2.top"
  End If
  
  For i = 1 To sr.Count - 1 Step 2
    Set Line = DrawLine(sr(i), sr(i + 1))
    sr_lines.Add Line
  Next
 
  sr_lines.CreateSelection
ErrorHandler:
  API.EndOpt
End Function


Public Function FirtLineTool()
  Dim sr As ShapeRange
  Set sr = ActiveSelectionRange
  If sr.Count > 1 Then
    Set Line = DrawLine(sr(1), sr(2))
  End If
End Function

Private Function DrawLine(ByVal s1 As Shape, ByVal s2 As Shape) As Shape
'// 创建线段方法在图层上的指定位置创建由单个线段组成的曲线。
 Set DrawLine = ActiveLayer.CreateLineSegment(s1.CenterX, s1.CenterY, s2.CenterX, s2.CenterY)

End Function




Sub Test()
  ActiveDocument.Unit = cdrMillimeter

 Set Rect = ActiveLayer.CreateRectangle(0, 0, 30, 30)
 Set ell = ActiveLayer.CreateEllipse2(50, 50, 10, 10)

 Set Line = DrawLine(Rect, ell)

End Sub