Sub 交点处等间距打断()
On Error Resume Next
Dim ssetObj As AcadSelectionSet
'创建选择集
Set ssetObj = ThisDrawing.SelectionSets("test")
If Err Then
Err.Clear
Set ssetObj = ThisDrawing.SelectionSets.Add("test")
End If
ssetObj.Clear '首先清空选择集
ssetObj.Select acSelectionSetAll
Dim jianju As Double
jianju = ThisDrawing.Utility.GetReal("指定打断间距：")
If Err Then Exit Sub
' 取得交点
Dim i As Long
Dim j As Long
Dim k As Long
Dim pt As Variant
Dim points() As Double
Dim N As Long
N = 0
For i = 0 To ssetObj.Count - 2
For j = i + 1 To ssetObj.Count - 1
pt = ssetObj(i).IntersectWith(ssetObj(j), acExtendNone)
If UBound(pt) >= 2 Then
ReDim Preserve points(N + UBound(pt)) '逐步定义数组，需要关键字
For k = 0 To UBound(pt)
points(N + k) = pt(k)
Next
N = N + UBound(pt) + 1
End If
Next
Next
'交点处打断
Dim bpt(0 To 2) As Double
Dim circleObj As AcadCircle
Dim cpt As Variant
Dim cpt1(2) As Double
Dim cpt2(2) As Double
Dim ss As AcadSelectionSet
Set ss = ThisDrawing.SelectionSets("dog")
If Err Then
Err.Clear
Set ss = ThisDrawing.SelectionSets.Add("dog")
End If
For i = 0 To UBound(points) Step 3
bpt(0) = points(i)
bpt(1) = points(i + 1)
bpt(2) = points(i + 2)
ss.Clear
SelectAtPoint ss, bpt
Set circleObj = ThisDrawing.ModelSpace.AddCircle(bpt, jianju / 2)
For k = 0 To ss.Count - 1
cpt = ss(k).IntersectWith(circleObj, acExtendNone)
If UBound(cpt) = 5 Then
cpt1(0) = cpt(0)
cpt1(1) = cpt(1)
cpt1(2) = cpt(2)
cpt2(0) = cpt(3)
cpt2(1) = cpt(4)
cpt2(2) = cpt(5)
ThisDrawing.SendCommand "_break" & vbCr & axEnt2lspEnt(ss(k)) & vbCr & axPoint2lspPoint(cpt1) & vbCr & axPoint2lspPoint(cpt2) & vbCr
End If
Next
circleObj.Delete
Next
End Sub
' 选择通过某点的实体
Public Sub SelectAtPoint(ByRef SSet As AcadSelectionSet, ByVal pt As Variant)
' 构造一个以pt为中心的小矩形作为选择范围
Dim pt1 As Variant, pt2 As Variant
Dim objUtility As Object
Set objUtility = ThisDrawing.Utility ' 必须使用后期绑定
objUtility.CreateTypedArray pt1, vbDouble, pt(0) - 0.0001, pt(1) - 0.0001, pt(2)
objUtility.CreateTypedArray pt2, vbDouble, pt(0) + 0.0001, pt(1) + 0.0001, pt(2)
SSet.Select acSelectionSetCrossing, pt1, pt2
End Sub
' 转换点的函数
Public Function axPoint2lspPoint(ByVal pnt As Variant) As String
axPoint2lspPoint = pnt(0) & "," & pnt(1) & "," & pnt(2)
End Function
' 转换图元函数
Public Function axEnt2lspEnt(ByVal entObj As AcadEntity) As String
Dim entHandle As String
entHandle = entObj.Handle
axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function
/1 
