VBA如何实现删除图形文件中的重复实体

dchlmz

我想问在CAD文件中有重复的线和文字，如何实现删除图形文件中的重复实体？先谢谢了

mikewolf2k

难度大,怎样判断重复?

雪山飞狐_lzh

判断重复，对线判断两端点，对文本判断插入点和文本值

mikewolf2k

没这么简单.


对线,每根线得与其它所有线比较,两根线的4个端点要在同一直线上.要做起来非常麻烦,对此不报希望.

mikewolf2k

有什么区别?建立选择集只不过是要比较的线的数目少一点,方法还是一样.

雪山飞狐_lzh

你说的问题我以前做过类似的东东：一个两人对弈围棋的程序，确实很复杂

yipinbing

object.delete要是不行你就用


ThisDrawing.SendCommand "_erase" & vbCr & "（要删除的东西）" & vbCr & vbCr


看看行么？有的东西我就是这么删的

雪山飞狐_lzh

2. Public Function GetVal(Line1 As AcadLine, Line2 As AcadLine) As Integer
3. Dim c As AcadLine
4. Dim a(1) As Double, b(1) As Double
5. Dim d(2) As Double, e(2) As Double
6. If Line1.Angle <> Line2.Angle Then GetVal = 0: Exit Function
7. GetVal = 1
8. e(1) = 1
9. Set c = ThisDrawing.ModelSpace.AddLine(d, e)
10. If c.Angle = Line1.Angle Then
11.        h = c.StartPoint
12.        h(0) = h(0) + 1
13.        c.StartPoint = h
14. End If
15. f = c.IntersectWith(Line1, acExtendBoth)
16. g = c.IntersectWith(Line2, acExtendBoth)
17. c.Delete
18. If Abs(f(0) - g(0)) < 10 ^ -8 And Abs(f(1) - g(1)) < 10 ^ -8 Then
19.        GetVal = 2
20.        If Line1.StartPoint(0) = Line1.EndPoint(0) Then
21.                a(0) = Min(Line1.StartPoint(1), Line1.EndPoint(1))
22.                a(1) = Max(Line1.StartPoint(1), Line1.EndPoint(1))
23.                b(0) = Min(Line2.StartPoint(1), Line2.EndPoint(1))
24.                b(1) = Max(Line2.StartPoint(1), Line2.EndPoint(1))
25.        Else
26.                a(0) = Min(Line1.StartPoint(0), Line1.EndPoint(0))
27.                a(1) = Max(Line1.StartPoint(0), Line1.EndPoint(0))
28.                b(0) = Min(Line2.StartPoint(0), Line2.EndPoint(0))
29.                b(1) = Max(Line2.StartPoint(0), Line2.EndPoint(0))
30.        End If
31.        If (a(0) - b(1)) * (a(1) - b(0)) <= 0 Then GetVal = 3
32. End If
33. End Function
34. Function Min(Value1 As Variant, Value2 As Variant) As Variant
35. Min = Value1
36. If Value2 < Value1 Then Min = Value2
37. End Function
38. Function Max(Value1 As Variant, Value2 As Variant) As Variant
39. Max = Value1
40. If Value2 > Value1 Then Max = Value2
41. End Function

Public Function GetVal(Line1 As AcadLine, Line2 As AcadLine) As Integer Dim c As AcadLine Dim a(1) As Double, b(1) As Double Dim d(2) As Double, e(2) As Double If Line1.Angle <> Line2.Angle Then GetVal = 0: Exit Function GetVal = 1 e(1) = 1 Set c = ThisDrawing.ModelSpace.AddLine(d, e) If c.Angle = Line1.Angle Then        h = c.StartPoint        h(0) = h(0) + 1        c.StartPoint = h End If f = c.IntersectWith(Line1, acExtendBoth) g = c.IntersectWith(Line2, acExtendBoth) c.Delete If Abs(f(0) - g(0)) < 10 ^ -8 And Abs(f(1) - g(1)) < 10 ^ -8 Then        GetVal = 2        If Line1.StartPoint(0) = Line1.EndPoint(0) Then                a(0) = Min(Line1.StartPoint(1), Line1.EndPoint(1))                a(1) = Max(Line1.StartPoint(1), Line1.EndPoint(1))                b(0) = Min(Line2.StartPoint(1), Line2.EndPoint(1))                b(1) = Max(Line2.StartPoint(1), Line2.EndPoint(1))        Else                a(0) = Min(Line1.StartPoint(0), Line1.EndPoint(0))                a(1) = Max(Line1.StartPoint(0), Line1.EndPoint(0))                b(0) = Min(Line2.StartPoint(0), Line2.EndPoint(0))                b(1) = Max(Line2.StartPoint(0), Line2.EndPoint(0))        End If        If (a(0) - b(1)) * (a(1) - b(0)) <= 0 Then GetVal = 3 End If End Function Function Min(Value1 As Variant, Value2 As Variant) As Variant Min = Value1 If Value2 < Value1 Then Min = Value2 End Function Function Max(Value1 As Variant, Value2 As Variant) As Variant Max = Value1 If Value2 > Value1 Then Max = Value2 End Function

这是一个判断两直线是否平行且重合的程序不平行返回0平行但不在一直线上返回1平行且在一直线上但不相交返回2平行且在一直线上且相交返回3下一步应该简单了吧