框选连接直线

lennie

今天刚写的代码，发上来和大家共享一下。

2. Public Sub LJ()
   
3. Dim SsLine As AcadSelectionSet
   
4. Dim FilterType(0) As Integer
   
5. Dim FilterData(0) As Variant
   
6. CertificationSelect "ST"
   
7. Set SsLine = ThisDrawing.SelectionSets.Add("ST")
   
8. FilterType(0) = 0
   
9. FilterData(0) = "LINE"
   
10. SsLine.SelectOnScreen FilterType, FilterData
    
11. Do While LineJoin(SsLine)
    
12. Loop
    
13. Set SsLine = Nothing
    
14. End Sub
    
15. 
    
16. Public Function LineJoin(ByVal SS As AcadSelectionSet) As Boolean
    
17. If SS.Count < 2 Then
    
18. LineJoin = False
    
19. Exit Function
    
20. End If
    
21. Dim SJ1 As Double
    
22. Dim SJ2 As Double
    
23. Dim L1sp As Variant
    
24. Dim L1ep As Variant
    
25. Dim L2sp As Variant
    
26. Dim L2ep As Variant
    
27. Dim P1(0 To 5) As Double
    
28. Dim P2(0 To 5) As Double
    
29. Dim i As Integer
    
30. Dim j As Integer
    
31. For i = 0 To SS.Count - 1
    
32. For j = i + 1 To SS.Count - 1
    
33. If SS(i).Layer = SS(j).Layer Then
    
34. SJ1 = SjMj(SS(i).StartPoint, SS(i).EndPoint, SS(j).StartPoint)
    
35. SJ2 = SjMj(SS(i).StartPoint, SS(i).EndPoint, SS(j).EndPoint)
    
36. If SJ1 + SJ2 < 0.00000001 Then '可以调节计算误差
    
37. Dim Points(0 To 7) As Double
    
38. Dim LineObjs(0) As AcadEntity
    
39. Dim DelObjs(1) As AcadEntity
    
40. Dim StartPoint(0 To 2) As Double
    
41. Dim EndPoint(0 To 2) As Double
    
42. Dim n As Integer
    
43. L1sp = SS(i).StartPoint
    
44. L1ep = SS(i).EndPoint
    
45. L2sp = SS(j).StartPoint
    
46. L2ep = SS(j).EndPoint
    
47. Points(0) = L1sp(0): Points(1) = L1sp(1)
    
48. Points(2) = L1ep(0): Points(3) = L1ep(1)
    
49. Points(4) = L2sp(0): Points(5) = L2sp(1)
    
50. Points(6) = L2ep(0): Points(7) = L2ep(1)
    
51. StartPoint(0) = Points(0)
    
52. StartPoint(1) = Points(1)
    
53. For n = 0 To 7 Step 2
    
54. If Points(n) < StartPoint(0) Then
    
55. StartPoint(0) = Points(n)
    
56. StartPoint(1) = Points(n + 1)
    
57. End If
    
58. If Points(n) = StartPoint(0) And Points(n + 1) < StartPoint(1) Then
    
59. StartPoint(1) = Points(n + 1)
    
60. End If
    
61. Next
    
62. EndPoint(0) = Points(0)
    
63. EndPoint(1) = Points(1)
    
64. For n = 0 To 7 Step 2
    
65. If Points(n) > EndPoint(0) Then
    
66. EndPoint(0) = Points(n)
    
67. EndPoint(1) = Points(n + 1)
    
68. End If
    
69. If Points(n) = EndPoint(0) And Points(n + 1) > EndPoint(1) Then
    
70. EndPoint(1) = Points(n + 1)
    
71. End If
    
72. Next
    
73. Set LineObjs(0) = ThisDrawing.ModelSpace.AddLine(StartPoint, EndPoint)
    
74. LineObjs(0).Layer = SS(i).Layer
    
75. SS.AddItems LineObjs
    
76. Set DelObjs(0) = SS(i)
    
77. Set DelObjs(1) = SS(j)
    
78. SS.RemoveItems DelObjs
    
79. SS.Update
    
80. DelObjs(0).Delete
    
81. DelObjs(1).Delete
    
82. LineJoin = True
    
83. Exit Function
    
84. End If
    
85. End If
    
86. Next
    
87. Next
    
88. LineJoin = False
    
89. End Function

Public Sub LJ()<br /> Dim SsLine As AcadSelectionSet<br /> Dim FilterType(0) As Integer<br /> Dim FilterData(0) As Variant<br /> CertificationSelect "ST"<br /> Set SsLine = ThisDrawing.SelectionSets.Add("ST")<br /> FilterType(0) = 0<br /> FilterData(0) = "LINE"<br /> SsLine.SelectOnScreen FilterType, FilterData<br /> Do While LineJoin(SsLine)<br /> Loop<br /> Set SsLine = Nothing<br /> End Sub<br /> <br /> Public Function LineJoin(ByVal SS As AcadSelectionSet) As Boolean<br /> If SS.Count < 2 Then<br /> LineJoin = False<br /> Exit Function<br /> End If<br /> Dim SJ1 As Double<br /> Dim SJ2 As Double<br /> Dim L1sp As Variant<br /> Dim L1ep As Variant<br /> Dim L2sp As Variant<br /> Dim L2ep As Variant<br /> Dim P1(0 To 5) As Double<br /> Dim P2(0 To 5) As Double<br /> Dim i As Integer<br /> Dim j As Integer<br /> For i = 0 To SS.Count - 1<br /> For j = i + 1 To SS.Count - 1<br /> If SS(i).Layer = SS(j).Layer Then<br /> SJ1 = SjMj(SS(i).StartPoint, SS(i).EndPoint, SS(j).StartPoint)<br /> SJ2 = SjMj(SS(i).StartPoint, SS(i).EndPoint, SS(j).EndPoint)<br /> If SJ1 + SJ2 < 0.00000001 Then '可以调节计算误差<br /> Dim Points(0 To 7) As Double<br /> Dim LineObjs(0) As AcadEntity<br /> Dim DelObjs(1) As AcadEntity<br /> Dim StartPoint(0 To 2) As Double<br /> Dim EndPoint(0 To 2) As Double<br /> Dim n As Integer<br /> L1sp = SS(i).StartPoint<br /> L1ep = SS(i).EndPoint<br /> L2sp = SS(j).StartPoint<br /> L2ep = SS(j).EndPoint<br /> Points(0) = L1sp(0): Points(1) = L1sp(1)<br /> Points(2) = L1ep(0): Points(3) = L1ep(1)<br /> Points(4) = L2sp(0): Points(5) = L2sp(1)<br /> Points(6) = L2ep(0): Points(7) = L2ep(1)<br /> StartPoint(0) = Points(0)<br /> StartPoint(1) = Points(1)<br /> For n = 0 To 7 Step 2<br /> If Points(n) < StartPoint(0) Then<br /> StartPoint(0) = Points(n)<br /> StartPoint(1) = Points(n + 1)<br /> End If<br /> If Points(n) = StartPoint(0) And Points(n + 1) < StartPoint(1) Then<br /> StartPoint(1) = Points(n + 1)<br /> End If<br /> Next<br /> EndPoint(0) = Points(0)<br /> EndPoint(1) = Points(1)<br /> For n = 0 To 7 Step 2<br /> If Points(n) > EndPoint(0) Then<br /> EndPoint(0) = Points(n)<br /> EndPoint(1) = Points(n + 1)<br /> End If<br /> If Points(n) = EndPoint(0) And Points(n + 1) > EndPoint(1) Then<br /> EndPoint(1) = Points(n + 1)<br /> End If<br /> Next<br /> Set LineObjs(0) = ThisDrawing.ModelSpace.AddLine(StartPoint, EndPoint)<br /> LineObjs(0).Layer = SS(i).Layer<br /> SS.AddItems LineObjs<br /> Set DelObjs(0) = SS(i)<br /> Set DelObjs(1) = SS(j)<br /> SS.RemoveItems DelObjs<br /> SS.Update<br /> DelObjs(0).Delete<br /> DelObjs(1).Delete<br /> LineJoin = True<br /> Exit Function<br /> End If<br /> End If<br /> Next<br /> Next<br /> LineJoin = False<br /> End Function

lennie

要用到下面两个函数

2. Public Function SjMj(ByVal P1 As Variant, ByVal P2 As Variant, ByVal P3 As Variant) As Double '求三点的面积
   
3. On Error GoTo Err_handle
   
4. Dim a As Double
   
5. Dim b As Double
   
6. Dim c As Double
   
7. Dim p As Double
   
8. a = Sqr((P1(0) - P2(0)) ^ 2 + (P1(1) - P2(1)) ^ 2)
   
9. b = Sqr((P1(0) - P3(0)) ^ 2 + (P1(1) - P3(1)) ^ 2)
   
10. c = Sqr((P2(0) - P3(0)) ^ 2 + (P2(1) - P3(1)) ^ 2)
    
11. p = (a + b + c) / 2
    
12. SjMj = Sqr(p * (p - a) * (p - b) * (p - c))
    
13. Exit Function
    
14. Err_handle: 'VB的计算误差有时会导致(p - a) * (p - b) * (p - c)出现负数
    
15. SjMj = 0
    
16. End Function
    
17. 
    
18. Public Sub CertificationSelect(ByVal SelectName As String) '存在选择集时删除选择集
    
19. Dim Entry As AcadSelectionSet
    
20. For Each Entry In ThisDrawing.SelectionSets
    
21. If UCase(Entry.Name) = UCase(SelectName) Then
    
22. ThisDrawing.SelectionSets.Item(SelectName).Delete
    
23. Exit Sub
    
24. End If
    
25. Next
    
26. End Sub

Public Function SjMj(ByVal P1 As Variant, ByVal P2 As Variant, ByVal P3 As Variant) As Double '求三点的面积<br /> On Error GoTo Err_handle<br /> Dim a As Double<br /> Dim b As Double<br /> Dim c As Double<br /> Dim p As Double<br /> a = Sqr((P1(0) - P2(0)) ^ 2 + (P1(1) - P2(1)) ^ 2)<br /> b = Sqr((P1(0) - P3(0)) ^ 2 + (P1(1) - P3(1)) ^ 2)<br /> c = Sqr((P2(0) - P3(0)) ^ 2 + (P2(1) - P3(1)) ^ 2)<br /> p = (a + b + c) / 2<br /> SjMj = Sqr(p * (p - a) * (p - b) * (p - c))<br /> Exit Function<br /> Err_handle: 'VB的计算误差有时会导致(p - a) * (p - b) * (p - c)出现负数<br /> SjMj = 0<br /> End Function<br /> <br /> Public Sub CertificationSelect(ByVal SelectName As String) '存在选择集时删除选择集<br /> Dim Entry As AcadSelectionSet<br /> For Each Entry In ThisDrawing.SelectionSets<br /> If UCase(Entry.Name) = UCase(SelectName) Then<br /> ThisDrawing.SelectionSets.Item(SelectName).Delete<br /> Exit Sub<br /> End If<br /> Next<br /> End Sub

yanyanjun999

有啥用处，楼主能否详细说明下

lennie

功能简单的 里面有个精度调节的参数 对简化图形有用

xiaxiang

个人比较懒，楼主可不可以直接发个dvb上来？还有，楼主开发过对应的lsp版本吗

lennie

对不起 我比你还要懒

chpmould

如果程序能改为NET写那就好了...

hsx5233408

赞个先

睡醒的蜗牛

赞踩踩踩踩踩踩踩踩