进来指点一二,谢谢

kinglau

我想计算铝型材的外顶点个数,我的想法是把所有图元形成面域,然后比较出最大的面域,统计出此面域的顶点一个,但是我觉得麻烦了点,形成面域后以后又要炸开,有没有更简单点的方法,请指点一二

雪山飞狐_lzh

贴图说明一下

kinglau

不会发图片,呵呵

雪山飞狐_lzh

？

kinglau

我编写了一段程序，不过好象有点问题

Sub point()
      Dim entcount As Integer
    
      Dim i As Integer
     
      Dim regcout As Integer
      Dim regionobj As Variant
      Dim outregion As AcadRegion
     
      Dim Selects As AcadSelectionSet
      Dim p As Integer
      ReDim entobj(0 To entcount - 1) As AcadEntity
      ReDim regions(0 To regcount - 1) As Variant
      entcount = ThisDrawing.ModelSpace.Count
     
      For i = 0 To entcount - 1
          Set entobj(i) = ThisDrawing.ModelSpace.Item(i)          '将图上图元付给图元数组
      Next
      regionobj = ThisDrawing.ModelSpace.AddRegion(entobj)        '将图元组合成区域
      For i = 0 To entcount - 1
          entobj(i).Delete
      Next
      regcount = ThisDrawing.ModelSpace.Count
      If regcount = 1 Then
         Set outregion = ThisDrawing.ModelSpace.Item(0)
      End If
      Do Until regcount = 1
    
      For i = 0 To regcount - 1
          Set regions(i) = ThisDrawing.ModelSpace.Item(i)
      Next
      Set outregion = regions(0)
      Loop
      For i = 1 To regcount - 1
          If regions(i).Area > outregion.Area Then
             Set outregion = regions(i)
          End If
      Next
      Selects.AddItems outregion
      For Each entity In Selects
      If UCase(entity.ObjectName) = "ACDBpoint" Then
         p = p + 1
         End If
         Next
        MsgBox p
   
End Sub

雪山飞狐_lzh

你要获取的到底是什么？

是外部包装尺寸？

kinglau

就是要计算最外层的顶点的个数

kinglau

只要获得点的个数就可以了

雪山飞狐_lzh

图里只有这些图元？

没有其它的？

不用选择么？

雪山飞狐_lzh

注意AddRegion返回的是数组！

下面的函数利用AddRegion函数的返回值获取顶点数（和实体数相等）

Private Function GetPointCount(Regions As Variant)
On Error Resume Next
     Dim pRegion As AcadRegion
     Dim i As AcadEntity
    
     '遍历面域数组找到最大面域
     For Each i In Regions
        If pRegion.Area < i.Area Then
            Set pRegion = i
        End If
     Next i
    
     objs = pRegion.Explode()
     GetPointCount = UBound(objs)
    
     For Each i In objs
        i.Delete
     Next i
    
End Function