框选连接直线
本帖最后由 lennie 于 2010-12-13 20:00 编辑今天刚写的代码，发上来和大家共享一下。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.Count < 2 Then
LineJoin = False
Exit Function
End If
Dim SJ1 As Double
Dim SJ2 As Double
Dim L1sp As Variant
Dim L1ep As Variant
Dim L2sp As Variant
Dim L2ep As Variant
Dim P1(0 To 5) As Double
Dim P2(0 To 5) As Double
Dim i As Integer
Dim j As Integer
For i = 0 To SS.Count - 1
For j = i + 1 To SS.Count - 1
If SS(i).Layer = SS(j).Layer Then
SJ1 = SjMj(SS(i).StartPoint, SS(i).EndPoint, SS(j).StartPoint)
SJ2 = SjMj(SS(i).StartPoint, SS(i).EndPoint, SS(j).EndPoint)
If SJ1 + SJ2 < 0.00000001 Then '可以调节计算误差
Dim Points(0 To 7) As Double
Dim LineObjs(0) As AcadEntity
Dim DelObjs(1) As AcadEntity
Dim StartPoint(0 To 2) As Double
Dim EndPoint(0 To 2) As Double
Dim n As Integer
L1sp = SS(i).StartPoint
L1ep = SS(i).EndPoint
L2sp = SS(j).StartPoint
L2ep = SS(j).EndPoint
Points(0) = L1sp(0): Points(1) = L1sp(1)
Points(2) = L1ep(0): Points(3) = L1ep(1)
Points(4) = L2sp(0): Points(5) = L2sp(1)
Points(6) = L2ep(0): Points(7) = L2ep(1)
StartPoint(0) = Points(0)
StartPoint(1) = Points(1)
For n = 0 To 7 Step 2
If Points(n) < StartPoint(0) Then
StartPoint(0) = Points(n)
StartPoint(1) = Points(n + 1)
End If
If Points(n) = StartPoint(0) And Points(n + 1) < StartPoint(1) Then
StartPoint(1) = Points(n + 1)
End If
Next
EndPoint(0) = Points(0)
EndPoint(1) = Points(1)
For n = 0 To 7 Step 2
If Points(n) > EndPoint(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
本帖最后由 lennie 于 2010-12-13 20:02 编辑
要用到下面两个函数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版本吗 对不起 我比你还要懒 本帖最后由 chpmould 于 2010-12-18 20:06 编辑
如果程序能改为NET写那就好了... 赞个先 赞踩踩踩踩踩踩踩踩
页:
[1]