还是直线问题

ahlzl

cxf11991发表于2004-6-4 17:11:00我做的是关于剪切线段的代码 比如说有4条直线成井字放置，长短都不一样，我想把交点之间的线段都剪掉，

这样：

2. Option ExplicitPublic Sub CrossWall()
3. Dim hline1 As AcadLine, hline2 As AcadLine, vline1 As AcadLine, vline2 As AcadLine
4. Dim hline11 As AcadLine, hline12 As AcadLine
5. Dim hline21 As AcadLine, hline22 As AcadLine
6. Dim vline11 As AcadLine, vline12 As AcadLine
7. Dim vline21 As AcadLine, vline22 As AcadLine
8. Dim p1, p2, p3, p4 As Variant
9. Dim sset As AcadSelectionSet
10. Dim scount As Integer, i As Integer   i = ThisDrawing.SelectionSets.Count
11.    
12.    While (i > 0)
13.            Set sset = ThisDrawing.SelectionSets.Item(i - 1)
14.            If sset.Name = "EXTSET" Then
15.                    sset.Delete
16.            End If
17.            i = i - 1
18.    Wend
19.    
20.    Set sset = ThisDrawing.SelectionSets.Add("EXTSET")   ThisDrawing.Utility.Prompt "请「框选」欲修十字交角的墙线....."
21. Dim cwp1, cwp2, interpt
22.    
23.    cwp1 = ThisDrawing.Utility.GetPoint(, "框选的第一点:")
24.    cwp2 = ThisDrawing.Utility.GetCorner(cwp1, "框选的对角点:")
25.    
26. Dim gpCode(0) As Integer
27. Dim dataValue(0) As Variant
28.    gpCode(0) = 0
29.    dataValue(0) = "Line"
30.    
31. Dim groupCode As Variant, dataCode As Variant
32.    groupCode = gpCode
33.    dataCode = dataValue
34.    
35.    sset.Select acSelectionSetCrossing, cwp1, cwp2, groupCode, dataCode   scount = sset.Count
36.       
37.    If scount > 4 Then
38.        MsgBox "您框选了超过四条以上的墙线. 请再执行程序一次....", vbOKOnly, "trim error"
39.        Exit Sub
40.    ElseIf scount < 4 Then
41.        MsgBox "您框选了的墙线少于四条. 请再执行程序一次....", vbOKOnly, "trim error"
42.        Exit Sub
43.    End If
44.    
45.    
46.    Set hline1 = sset.Item(0)
47.    
48.    Dim si As Integer
49.    
50.    For si = 1 To 3
51.        interpt = hline1.IntersectWith(sset.Item(si), acExtendNone)
52.        If UBound(interpt) = -1 Then
53.            Set hline2 = sset.Item(si)
54.        End If
55.    Next
56.    
57.    For si = 1 To 3
58.        If sset.Item(si).ObjectID <> hline1.ObjectID And sset.Item(si).ObjectID <> hline2.ObjectID Then
59.            Set vline1 = sset.Item(si)
60.        End If
61.    Next
62.    For si = 1 To 3
63.        If sset.Item(si).ObjectID <> hline1.ObjectID And _
64.        sset.Item(si).ObjectID <> hline2.ObjectID And sset.Item(si).ObjectID <> vline1.ObjectID Then
65.            Set vline2 = sset.Item(si)
66.        End If
67.    Next
68.    
69.    p1 = hline1.IntersectWith(vline1, acExtendNone)
70.    p2 = hline1.IntersectWith(vline2, acExtendNone)
71.    p3 = hline2.IntersectWith(vline1, acExtendNone)
72.    p4 = hline2.IntersectWith(vline2, acExtendNone)
73.    If UBound(p1) = -1 Or UBound(p2) = -1 Or UBound(p3) = -1 Or UBound(p4) = -1 Then
74.        MsgBox "您所选取的墙线无法在 X 方向做截取动作，请于修正错误后，再试一次！", vbOKOnly
75.        Exit Sub
76.    End If
77.    
78.    If distance(hline1.StartPoint, p1) > distance(hline1.StartPoint, p2) Then
79.        Set hline11 = ThisDrawing.ModelSpace.AddLine(hline1.StartPoint, p2)
80.        Set hline12 = ThisDrawing.ModelSpace.AddLine(hline1.EndPoint, p1)
81.    Else
82.        Set hline11 = ThisDrawing.ModelSpace.AddLine(hline1.StartPoint, p1)
83.        Set hline12 = ThisDrawing.ModelSpace.AddLine(hline1.EndPoint, p2)
84.    End If
85.    
86.    If distance(hline2.StartPoint, p3) > distance(hline1.StartPoint, p4) Then
87.        Set hline21 = ThisDrawing.ModelSpace.AddLine(hline2.StartPoint, p4)
88.        Set hline22 = ThisDrawing.ModelSpace.AddLine(hline2.EndPoint, p3)
89.    Else
90.        Set hline21 = ThisDrawing.ModelSpace.AddLine(hline2.StartPoint, p3)
91.        Set hline22 = ThisDrawing.ModelSpace.AddLine(hline2.EndPoint, p4)
92.    End If
93.    
94.    If distance(vline1.StartPoint, p1) > distance(vline1.StartPoint, p3) Then
95.        Set vline11 = ThisDrawing.ModelSpace.AddLine(vline1.StartPoint, p3)
96.        Set vline12 = ThisDrawing.ModelSpace.AddLine(vline1.EndPoint, p1)
97.    Else
98.        Set vline11 = ThisDrawing.ModelSpace.AddLine(vline1.StartPoint, p1)
99.        Set vline12 = ThisDrawing.ModelSpace.AddLine(vline1.EndPoint, p3)
100.    End If
101.    
102.    If distance(vline2.StartPoint, p2) > distance(vline2.StartPoint, p4) Then
103.        Set vline21 = ThisDrawing.ModelSpace.AddLine(vline2.StartPoint, p4)
104.        Set vline22 = ThisDrawing.ModelSpace.AddLine(vline2.EndPoint, p2)
105.    Else
106.        Set vline21 = ThisDrawing.ModelSpace.AddLine(vline2.StartPoint, p2)
107.        Set vline22 = ThisDrawing.ModelSpace.AddLine(vline2.EndPoint, p4)
108.    End If
109.    
110.    hline11.Layer = hline1.Layer
111.    hline12.Layer = hline1.Layer
112.    hline21.Layer = hline1.Layer
113.    hline22.Layer = hline1.Layer
114.    vline11.Layer = hline1.Layer
115.    vline12.Layer = hline1.Layer
116.    vline21.Layer = hline1.Layer
117.    vline22.Layer = hline1.Layer
118.    
119.    hline1.Delete
120.    hline2.Delete
121.    vline1.Delete
122.    vline2.Delete
123. End Sub
124. Function distance(pt1, pt2 As Variant) As Double
125.        distance = ((pt1(0) - pt2(0)) ^ 2 + (pt1(1) - pt2(1)) ^ 2) ^ 0.5
126. End Function

Option ExplicitPublic Sub CrossWall() Dim hline1 As AcadLine, hline2 As AcadLine, vline1 As AcadLine, vline2 As AcadLine Dim hline11 As AcadLine, hline12 As AcadLine Dim hline21 As AcadLine, hline22 As AcadLine Dim vline11 As AcadLine, vline12 As AcadLine Dim vline21 As AcadLine, vline22 As AcadLine Dim p1, p2, p3, p4 As Variant Dim sset As AcadSelectionSet Dim scount As Integer, i As Integer   i = ThisDrawing.SelectionSets.Count        While (i > 0)            Set sset = ThisDrawing.SelectionSets.Item(i - 1)            If sset.Name = "EXTSET" Then                    sset.Delete            End If            i = i - 1    Wend        Set sset = ThisDrawing.SelectionSets.Add("EXTSET")   ThisDrawing.Utility.Prompt "请「框选」欲修十字交角的墙线....." Dim cwp1, cwp2, interpt        cwp1 = ThisDrawing.Utility.GetPoint(, "框选的第一点:")    cwp2 = ThisDrawing.Utility.GetCorner(cwp1, "框选的对角点:")     Dim gpCode(0) As Integer Dim dataValue(0) As Variant    gpCode(0) = 0    dataValue(0) = "Line"     Dim groupCode As Variant, dataCode As Variant    groupCode = gpCode    dataCode = dataValue        sset.Select acSelectionSetCrossing, cwp1, cwp2, groupCode, dataCode   scount = sset.Count           If scount > 4 Then        MsgBox "您框选了超过四条以上的墙线. 请再执行程序一次....", vbOKOnly, "trim error"        Exit Sub    ElseIf scount < 4 Then        MsgBox "您框选了的墙线少于四条. 请再执行程序一次....", vbOKOnly, "trim error"        Exit Sub    End If            Set hline1 = sset.Item(0)        Dim si As Integer        For si = 1 To 3        interpt = hline1.IntersectWith(sset.Item(si), acExtendNone)        If UBound(interpt) = -1 Then            Set hline2 = sset.Item(si)        End If    Next        For si = 1 To 3        If sset.Item(si).ObjectID <> hline1.ObjectID And sset.Item(si).ObjectID <> hline2.ObjectID Then            Set vline1 = sset.Item(si)        End If    Next    For si = 1 To 3        If sset.Item(si).ObjectID <> hline1.ObjectID And _        sset.Item(si).ObjectID <> hline2.ObjectID And sset.Item(si).ObjectID <> vline1.ObjectID Then            Set vline2 = sset.Item(si)        End If    Next        p1 = hline1.IntersectWith(vline1, acExtendNone)    p2 = hline1.IntersectWith(vline2, acExtendNone)    p3 = hline2.IntersectWith(vline1, acExtendNone)    p4 = hline2.IntersectWith(vline2, acExtendNone)    If UBound(p1) = -1 Or UBound(p2) = -1 Or UBound(p3) = -1 Or UBound(p4) = -1 Then        MsgBox "您所选取的墙线无法在 X 方向做截取动作，请于修正错误后，再试一次！", vbOKOnly        Exit Sub    End If        If distance(hline1.StartPoint, p1) > distance(hline1.StartPoint, p2) Then        Set hline11 = ThisDrawing.ModelSpace.AddLine(hline1.StartPoint, p2)        Set hline12 = ThisDrawing.ModelSpace.AddLine(hline1.EndPoint, p1)    Else        Set hline11 = ThisDrawing.ModelSpace.AddLine(hline1.StartPoint, p1)        Set hline12 = ThisDrawing.ModelSpace.AddLine(hline1.EndPoint, p2)    End If        If distance(hline2.StartPoint, p3) > distance(hline1.StartPoint, p4) Then        Set hline21 = ThisDrawing.ModelSpace.AddLine(hline2.StartPoint, p4)        Set hline22 = ThisDrawing.ModelSpace.AddLine(hline2.EndPoint, p3)    Else        Set hline21 = ThisDrawing.ModelSpace.AddLine(hline2.StartPoint, p3)        Set hline22 = ThisDrawing.ModelSpace.AddLine(hline2.EndPoint, p4)    End If        If distance(vline1.StartPoint, p1) > distance(vline1.StartPoint, p3) Then        Set vline11 = ThisDrawing.ModelSpace.AddLine(vline1.StartPoint, p3)        Set vline12 = ThisDrawing.ModelSpace.AddLine(vline1.EndPoint, p1)    Else        Set vline11 = ThisDrawing.ModelSpace.AddLine(vline1.StartPoint, p1)        Set vline12 = ThisDrawing.ModelSpace.AddLine(vline1.EndPoint, p3)    End If        If distance(vline2.StartPoint, p2) > distance(vline2.StartPoint, p4) Then        Set vline21 = ThisDrawing.ModelSpace.AddLine(vline2.StartPoint, p4)        Set vline22 = ThisDrawing.ModelSpace.AddLine(vline2.EndPoint, p2)    Else        Set vline21 = ThisDrawing.ModelSpace.AddLine(vline2.StartPoint, p2)        Set vline22 = ThisDrawing.ModelSpace.AddLine(vline2.EndPoint, p4)    End If        hline11.Layer = hline1.Layer    hline12.Layer = hline1.Layer    hline21.Layer = hline1.Layer    hline22.Layer = hline1.Layer    vline11.Layer = hline1.Layer    vline12.Layer = hline1.Layer    vline21.Layer = hline1.Layer    vline22.Layer = hline1.Layer        hline1.Delete    hline2.Delete    vline1.Delete    vline2.Delete End Sub Function distance(pt1, pt2 As Variant) As Double        distance = ((pt1(0) - pt2(0)) ^ 2 + (pt1(1) - pt2(1)) ^ 2) ^ 0.5 End Function

cxf11991

谢谢大家，我昨天重新做了一次，发现了几个错误，现在的程序是可行的，有兴趣的可以看看 我做的是关于剪切线段的代码 比如说有4条直线成井字放置，长短都不一样， 我想把交点之间的线段都剪掉， 编了下面部分代码 flog = True For Each entobj3 In objselectionset1 For Each entobj4 In objselectionset4 Set lineobj = entobj3 pt = entobj3.IntersectWith(entobj4, acExtendNone) If flog = True Then set lineobj1 = ThisDrawing.ModelSpace.AddLine(lineobj.StartPoint, pt) set lineobj2 = ThisDrawing.ModelSpace.AddLine(lineobj.EndPoint, pt) flog = False Else set lineobj3 = ThisDrawing.ModelSpace.AddLine(lineobj.StartPoint, pt) set lineobj4 = ThisDrawing.ModelSpace.AddLine(lineobj.EndPoint, pt) If Sqr((lineobj1.StartPoint(0) - lineobj1.EndPoint(0)) ^ 2 + (lineobj1.StartPoint(1) - lineobj1.EndPoint(1)) ^ 2) < Sqr((lineobj3.StartPoint(0) - lineobj3.EndPoint(0)) ^ 2 + (lineobj3.StartPoint(1) - lineobj3.EndPoint(1)) ^ 2) Then lineobj3.Delete Else: lineobj1.Delete End If If Sqr((lineobj2.StartPoint(0) - lineobj2.EndPoint(0)) ^ 2 + (lineobj2.StartPoint(1) - lineobj2.EndPoint(1)) ^ 2) < Sqr((lineobj4.StartPoint(0) - lineobj4.EndPoint(0)) ^ 2 + (lineobj4.StartPoint(1) - lineobj4.EndPoint(1)) ^ 2) Then lineobj4.Delete Else: lineobj2.Delete End If flog = True End If Next entobj3.Delete Next 其中objselectionset1为两条横放直线，objselectionset2为两条竖放直线

这样就可以剪切两条相交直线了，另外两条直线剪切原理一样，选择集反一下，就可以了