有关图形最外围边界生成问题

zwd0077

请教VBA有没有什么方法可以生成图形最处围的边界,因图形内部有多个封闭区域,无法使用CAD的边界命令

wyj7485

取得所有实体的GetBoundingBox，比较得到最大，最小坐标

zwd0077

能给一段代码参考一下吗?谢谢

wyj7485

2. Sub test()
3. On Error Resume Next
4. Dim Sset As AcadSelectionSet
5. Dim i, keyword, KeyStr, MySTr
6. Dim Pmax, Pmin, IniVar As Variant
7. Dim x0, y0, x1, y1, dd, ff, la, lb
8. Dim pt(7) As Double
9. Dim Pline As AcadLWPolyline
11. ThisDrawing.SelectionSets("Sset").Delete
12. Set Sset = ThisDrawing.SelectionSets.Add("Sset")
13. Sset.SelectOnScreen
14. Sset(0).GetBoundingBox Pmin, Pmax
15. x0 = Pmin(0): y0 = Pmin(1)
16. x1 = Pmax(0): y1 = Pmax(1)
17. For i = 1 To Sset.Count - 1
18. Sset(i).GetBoundingBox Pmin, Pmax
19. If x0 > Pmin(0) Then x0 = Pmin(0)
20. If y0 > Pmin(1) Then y0 = Pmin(1)
21. If x1 < Pmax(0) Then x1 = Pmax(0)
22. If y1 < Pmax(1) Then y1 = Pmax(1)
23. Next
24. pt(0) = x0
25. pt(1) = y0
26. pt(2) = x1
27. pt(3) = y0
28. pt(4) = x1
29. pt(5) = y1
30. pt(6) = x0
31. pt(7) = y1
32. Set Pline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
33. Pline.Closed = True
34. End Sub

Sub test() On Error Resume Next Dim Sset As AcadSelectionSet Dim i, keyword, KeyStr, MySTr Dim Pmax, Pmin, IniVar As Variant Dim x0, y0, x1, y1, dd, ff, la, lb Dim pt(7) As Double Dim Pline As AcadLWPolyline ThisDrawing.SelectionSets("Sset").Delete Set Sset = ThisDrawing.SelectionSets.Add("Sset") Sset.SelectOnScreen Sset(0).GetBoundingBox Pmin, Pmax x0 = Pmin(0): y0 = Pmin(1) x1 = Pmax(0): y1 = Pmax(1) For i = 1 To Sset.Count - 1 Sset(i).GetBoundingBox Pmin, Pmax If x0 > Pmin(0) Then x0 = Pmin(0) If y0 > Pmin(1) Then y0 = Pmin(1) If x1 < Pmax(0) Then x1 = Pmax(0) If y1 < Pmax(1) Then y1 = Pmax(1) Next pt(0) = x0 pt(1) = y0 pt(2) = x1 pt(3) = y0 pt(4) = x1 pt(5) = y1 pt(6) = x0 pt(7) = y1 Set Pline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt) Pline.Closed = True End Sub