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

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

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

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

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