框选连接直线
今天刚写的代码，发上来和大家共享一下。Public Sub LJ()
Dim SsLine As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
CertificationSelect "ST"
Set SsLine = ThisDrawing.SelectionSets.Add("ST")
FilterType(0) = 0
FilterData(0) = "LINE"
SsLine.SelectOnScreen FilterType, FilterData
Do While LineJoin(SsLine)
Loop
Set SsLine = Nothing
End Sub
Public Function LineJoin(ByVal SS As AcadSelectionSet) As Boolean
If SS.CountEndPoint(0) Then
EndPoint(0) = Points(n)
EndPoint(1) = Points(n + 1)
End If
If Points(n) = EndPoint(0) And Points(n + 1) > EndPoint(1) Then
EndPoint(1) = Points(n + 1)
End If
Next
Set LineObjs(0) = ThisDrawing.ModelSpace.AddLine(StartPoint, EndPoint)
LineObjs(0).Layer = SS(i).Layer
SS.AddItems LineObjs
Set DelObjs(0) = SS(i)
Set DelObjs(1) = SS(j)
SS.RemoveItems DelObjs
SS.Update
DelObjs(0).Delete
DelObjs(1).Delete
LineJoin = True
Exit Function
End If
End If
Next
Next
LineJoin = False
End Function
要用到下面两个函数
Public Function SjMj(ByVal P1 As Variant, ByVal P2 As Variant, ByVal P3 As Variant) As Double '求三点的面积
On Error GoTo Err_handle
Dim a As Double
Dim b As Double
Dim c As Double
Dim p As Double
a = Sqr((P1(0) - P2(0)) ^ 2 + (P1(1) - P2(1)) ^ 2)
b = Sqr((P1(0) - P3(0)) ^ 2 + (P1(1) - P3(1)) ^ 2)
c = Sqr((P2(0) - P3(0)) ^ 2 + (P2(1) - P3(1)) ^ 2)
p = (a + b + c) / 2
SjMj = Sqr(p * (p - a) * (p - b) * (p - c))
Exit Function
Err_handle: 'VB的计算误差有时会导致(p - a) * (p - b) * (p - c)出现负数
SjMj = 0
End Function
Public Sub CertificationSelect(ByVal SelectName As String) '存在选择集时删除选择集
Dim Entry As AcadSelectionSet
For Each Entry In ThisDrawing.SelectionSets
If UCase(Entry.Name) = UCase(SelectName) Then
ThisDrawing.SelectionSets.Item(SelectName).Delete
Exit Sub
End If
Next
End Sub
有啥用处，楼主能否详细说明下 功能简单的 里面有个精度调节的参数 对简化图形有用
框选连接直线
个人比较懒，楼主可不可以直接发个dvb上来？还有，楼主开发过对应的lsp版本吗 对不起 我比你还要懒
如果程序能改为NET写那就好了... 赞个先 赞踩踩踩踩踩踩踩踩
页:
[1]