|
|
源程序如下：
Sub r4() '打断
Dim returnObj As AcadEntity
Dim x(2), y(2) As Double
Dim ss(100000) As Variant
Dim det As String
Dim det1 As String
Dim lspPnt As String
Dim minp, maxp As Variant
Dim ssetobj, ssetobj2 As AcadSelectionSet
Dim ent As AcadEntity
'ScreenUpdating = False
On Error Resume Next
SsetName = "au100"
On Error Resume Next
For i = 0 To ThisDrawing.SelectionSets.Count - 1
Set ssetobj = ThisDrawing.SelectionSets.Item(i)
If ssetobj.Name = "au100" Then ssetobj.Delete
Next i
Set ssetobj = ThisDrawing.SelectionSets.Add(SsetName)
ssetobj.SelectOnScreen
k = 0
j = ssetobj.Count
For i = 0 To j - 1
For ii = 0 To j - 1
If Abs(ssetobj.Item(i).Angle - ssetobj.Item(ii).Angle) > 0.5 Then
ss(k) = ssetobj.Item(i).IntersectWith(ssetobj.Item(ii), acExtendBoth)
det = GetDoubleEntTable(ssetobj.Item(i), ss(k))
det1 = GetDoubleEntTable(ssetobj.Item(ii), ss(k))
lspPnt = axPoint2lspPoint(ss(k))
ThisDrawing.SendCommand "_break" & vbCr & det & vbCr & lspPnt & vbCr
ThisDrawing.SendCommand "_break" & vbCr & det1 & vbCr & lspPnt & vbCr
k = k + 1
End If
Next
Next
SsetName = "au101"
On Error Resume Next
For i = 0 To ThisDrawing.SelectionSets.Count - 1
Set ssetobj2 = ThisDrawing.SelectionSets.Item(i)
If ssetobj2.Name = "au101" Then ssetobj2.Delete
Next i
Set ssetobj2 = ThisDrawing.SelectionSets.Add(SsetName)
ssetobj2.SelectOnScreen '删除打断中产生的小雨1000的直线
For Each returnObj In ssetobj2
If returnObj.Length
'转换双元表的函数
Public Function GetDoubleEntTable(entObj As AcadEntity, Pnt As Variant) As String
Dim entHandle As String
entHandle = entObj.Handle
GetDoubleEntTable = "(list(handent " & Chr(34) & entHandle & Chr(34) & _
")(list " & Str(Pnt(0)) & Str(Pnt(1)) & Str(Pnt(2)) & "))"
End Function
'转换点的函数
Public Function axPoint2lspPoint(Pnt As Variant) As String
axPoint2lspPoint = Pnt(0) & "," & Pnt(1) & "," & Pnt(2)
End Function
'转换图元函数
Public Function axEnt2lspEnt(entObj As AcadEntity) As String
Dim entHandle As String
entHandle = entObj.Handle
axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function
|
|
置顶卡
