|
|
发表于 2008-6-20 17:10:00
|
显示全部楼层
程序如下，但是还是不能实现直线长度小于2000的自动删除，有时候可以，有时候不行，在vba界面里面按执行按钮可以，在cad里面里面点击“宏”运行就不行，为什么呢？
Sub r4() '相交的直线彼此打断
Dim returnObj As AcadEntity
Dim y(1 To 3) As Double
Dim ss(100000) As Variant
Dim det As String
Dim det1 As String
Dim lspPnt As String
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
j = SsetObj.Count
MsgBox j
k = 0
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
SsetObj.SelectAtPoint ss(k)
k = k + 1
End If
Next
Next
For i = 0 To SsetObj.Count
If SsetObj.Item(i).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)) & "))"
|
|
置顶卡
