自己写的一个多边形选择的例子

topirol

2. Sub selecebypoly()
   
3. Dim acaddoc As AcadDocument
   
4. Dim k As Integer, i As Integer
   
5. Dim pointarrays() As Double
   
6. Dim retent As Object
   
7. Dim tpolyline As AcadLWPolyline
   
8. Dim sel1 As AcadSelectionSet
   
9. On Error Resume Next
   
10. Set acaddoc = ThisDrawing
    
11. Set sel1 = acaddoc.SelectionSets("zjsel")
    
12. If Err Then
    
13. Err.Clear
    
14. Set sel1 = acaddoc.SelectionSets.Add("zjsel")
    
15. 
    
16. End If
    
17. sel1.Clear
    
18. 
    
19. Set retent = getneedobject(acaddoc)  '获得多边形
    
20. If retent.ObjectName = "AcDbPolyline" Then
    
21. Set tpolyline = retent
    
22. Else
    
23. End
    
24. End If
    
25. 
    
26. k = UBound(tpolyline.Coordinates)
    
27. k1 = (k + 1) * 1.5
    
28. 
    
29. ReDim pointarrays(0 To k1 - 1)
    
30. For i = 0 To k1 / 3 - 1 Step 1                  '把坐标赋值给数组
    
31. pointarrays(i * 3) = tpolyline.Coordinates(i * 2)
    
32. pointarrays(i * 3 + 1) = tpolyline.Coordinates(i * 2 + 1)
    
33. pointarrays(i * 3 + 2) = 0
    
34. Next
    
35. 
    
36. 
    
37. 
    
38. sel1.SelectByPolygon acSelectionSetWindowPolygon, pointarrays
    
39. MsgBox sel1.Count
    
40. End Sub
    
41. 
    
42. 
    
43. Function getneedobject(acaddoc As AcadDocument) As Object
    
44. On Error Resume Next
    
45. Dim retent As Object
    
46. Dim pnt As Variant
    
47. acaddoc.Utility.GetEntity retent, ont, "选择一个闭合多边形"
    
48. Dim errnum As Integer
    
49. errnum = 0
    
50. While Err
    
51.       Err.Clear
    
52.     errnum = errnum + 1
    
53.     If errnum < 3 Then
    
54.       acaddoc.Utility.GetEntity retent, ont, "选择一个闭合多边形"
    
55.     Else
    
56.     End
    
57.     End If
    
58. Wend
    
59. Set getneedobject = retent
    
60. End Function
    

Sub selecebypoly()<br /> Dim acaddoc As AcadDocument<br /> Dim k As Integer, i As Integer<br /> Dim pointarrays() As Double<br /> Dim retent As Object<br /> Dim tpolyline As AcadLWPolyline<br /> Dim sel1 As AcadSelectionSet<br /> On Error Resume Next<br /> Set acaddoc = ThisDrawing<br /> Set sel1 = acaddoc.SelectionSets("zjsel")<br /> If Err Then<br /> Err.Clear<br /> Set sel1 = acaddoc.SelectionSets.Add("zjsel")<br /> <br /> End If<br /> sel1.Clear<br /> <br /> Set retent = getneedobject(acaddoc)  '获得多边形<br /> If retent.ObjectName = "AcDbPolyline" Then<br /> Set tpolyline = retent<br /> Else<br /> End<br /> End If<br /> <br /> k = UBound(tpolyline.Coordinates)<br /> k1 = (k + 1) * 1.5<br /> <br /> ReDim pointarrays(0 To k1 - 1)<br /> For i = 0 To k1 / 3 - 1 Step 1                  '把坐标赋值给数组<br /> pointarrays(i * 3) = tpolyline.Coordinates(i * 2)<br /> pointarrays(i * 3 + 1) = tpolyline.Coordinates(i * 2 + 1)<br /> pointarrays(i * 3 + 2) = 0<br /> Next<br /> <br /> <br /> <br /> sel1.SelectByPolygon acSelectionSetWindowPolygon, pointarrays<br /> MsgBox sel1.Count<br /> End Sub<br /> <br /> <br /> Function getneedobject(acaddoc As AcadDocument) As Object<br /> On Error Resume Next<br /> Dim retent As Object<br /> Dim pnt As Variant<br /> acaddoc.Utility.GetEntity retent, ont, "选择一个闭合多边形"<br /> Dim errnum As Integer<br /> errnum = 0<br /> While Err<br />       Err.Clear<br />     errnum = errnum + 1<br />     If errnum < 3 Then<br />       acaddoc.Utility.GetEntity retent, ont, "选择一个闭合多边形"<br />     Else<br />     End<br />     End If<br /> Wend<br /> Set getneedobject = retent<br /> End Function<br />