社区 › VB › 请教各位大侠，关于polyline面积的问题，在线等待

mycad 发表于 2009-4-9 15:34:00

请教各位大侠，关于polyline面积的问题，在线等待

请教各位大侠：
Sub Example_Layer()   
'图在附件中，关于面积自动注记的一个小程序,在cad中绘制一个闭合的pl线，使用此程序自动注记面积
   Dim x, y As Double
   Dim coor() As Double
   Dim pt(2) As Double'注记坐标
   'Dim pl As AcadObject
   Dim pl As AcadEntity
   Dim pl1 As AcadPolyline
   Dim layerObj As AcadLayer
   Dim sset As AcadSelectionSet
   Dim zjtxt As AcadText
   'On Error Resume Next
   If Not IsNull(ThisDrawing.SelectionSets.Item("this")) Then
      Set sset = ThisDrawing.SelectionSets.Item("this")
      sset.Delete
   End If
   Set sset = ThisDrawing.SelectionSets.Add("this")
   sset.SelectOnScreen
   
    'Set layerObj = ThisDrawing.Layers.Add("ABC")
    Dim i As Integer
         
    For Each pl In sset
       'If entity.Layer = Trim(UserForm1.ComboBox1.Text) Then
      i = 0
      If pl.ObjectName = "AcDbPolyline" And pl.Closed = True Then
            i = i + 1
            
            
'这个地方出问题了，怎样解决？
            
            Set pl1 = pl
            
            
            coor = pl.Coordinates
         End If
         
         For i = 0 To (UBound(coor) - 1) Step 2
             'ss = ss + Str(coor(i)) + vbCrLf
             'ss = ss + Str(UBound(coor))
               x = x + coor(i)
               y = y + coor(i + 1)
         Next i
            pt(0) = x / ((UBound(coor) + 1) / 2)
            pt(1) = y / ((UBound(coor) + 1) / 2)
            pt(2) = 0
            Set zjtxt = ThisDrawing.ModelSpace.AddText(Str(pl1.Area), pt, 3)
       'End If
    Next
      'MsgBox Str(x / 4) + "," + Str(y / 4)
End Sub

mycad 发表于 2009-4-10 07:59:00

我已经解决了这个问题，如下即可：
本人在贵网站学到了很多知识，为了感谢贵网站，本人把修改完整的代码放在下面，调试通过
Sub Example_Layer()   
'图在附件中，关于面积自动注记的一个小程序,在cad中绘制一个闭合的pl线，使用此程序自动注记面积
   Dim x, y As Double
   Dim coor() As Double
   Dim pt(2) As Double'注记坐标
   'Dim pl As AcadObject
   Dim pl As AcadEntity
   Dim pl1 As AcadPolyline
   Dim layerObj As AcadLayer
   Dim sset As AcadSelectionSet
   Dim zjtxt As AcadText
   'On Error Resume Next
   If Not IsNull(ThisDrawing.SelectionSets.Item("this")) Then
      Set sset = ThisDrawing.SelectionSets.Item("this")
      sset.Delete
   End If
   Set sset = ThisDrawing.SelectionSets.Add("this")
   sset.SelectOnScreen
   
    'Set layerObj = ThisDrawing.Layers.Add("ABC")
    Dim i As Integer
         
    For Each pl In sset
       'If entity.Layer = Trim(UserForm1.ComboBox1.Text) Then
      i = 0
      If pl.ObjectName = "AcDbPolyline" And pl.Closed = True Then
            i = i + 1
            
            
'这个地方出问题了，怎样解决？
            
         ’ Set pl1 = pl
            
            
            coor = pl.Coordinates
         End If
         
         For i = 0 To (UBound(coor) - 1) Step 2
             'ss = ss + Str(coor(i)) + vbCrLf
             'ss = ss + Str(UBound(coor))
               x = x + coor(i)
               y = y + coor(i + 1)
         Next i
            pt(0) = x / ((UBound(coor) + 1) / 2)
            pt(1) = y / ((UBound(coor) + 1) / 2)
            pt(2) = 0
            Set zjtxt = ThisDrawing.ModelSpace.AddText(Str(pl.Area), pt, 3)
       'End If
    Next
exit sub
      'MsgBox Str(x / 4) + "," + Str(y / 4)
End Sub

查看完整版本: 请教各位大侠，关于polyline面积的问题，在线等待