cad墙线打断lisp_[求助]很多相交线快速打断 - AutoLISP/Visual LISP 编程技术 -

先提供一个交点处等距打断的vba程序，可根据需要来改进。

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

cad墙线打断lisp_[求助]很多相交线快速打断 - AutoLISP/Visual LISP 编程技术 - CAD论坛 - 明经CAD社区 - Powered by Discuz!...