如何通过VBA获得CAD鼠标获得点来画Polyline并封闭形成多边形，形成完毕再返回执行程
如何通过VBA获得CAD鼠标获得点来画Polyline并封闭形成多边形，形成完毕再返回执行程序如何通过VBA获得CAD鼠标获得点来画Polyline并封闭形成多边形，形成完毕再返回执行程序 这是一个获取逐点坐标计算面积的子程序，不知道合不合你的用？我在这里限制了20个点，先生成了一个polyline，然后获取面积，最后删除物体，也许对你没有，写的不好，高手见笑。Public Sub getab()<BR>'获得逐点面积<BR>Dim p() As Double<BR>Dim p1 As Variant<BR>Dim i As Integer<BR>Dim polyl As Object
On Error GoTo err:<BR>Call AcadOpen<BR>Set acadutil = acadObj.ActiveDocument.utility<BR><BR>AppActivate "Autocad" '
For i = 0 To 59 Step 3<BR> p1 = acadutil.Getpoint(, "输入欲调查面积的控制点... ")<BR> ReDim Preserve p(i + 2)<BR> p(i) = p1(0): p(i + 1) = p1(1): p(i + 2) = 0<BR> <BR>Next i<BR>err:<BR> If err.Number = -2145320928 Or err.Number = -2145320851 Then<BR> <BR> Set polyl = acadObj.ActiveDocument.ModelSpace.AddPolyline(p)<BR> grid.Text = Round(polyl.Area, sn)<BR> polyl.Delete<BR> Else:<BR> Exit Sub<BR> End If
End Sub<BR> <FONT face=宋体 size=2>Sub Test()<BR>On Error GoTo ErrHandle<BR>Dim pFrom, pTo<BR>Dim p1(3) As Double, p2(1) As Double<BR>Dim pPL As AcadLWPolyline<BR>pFrom = ThisDrawing.Utility.GetPoint(, vbCr & "请输入第一点：")<BR>pTo = ThisDrawing.Utility.GetPoint(pFrom, vbCr & "请输入下一点：")<BR>p1(0) = pFrom(0): p1(1) = pFrom(1)<BR>p1(2) = pTo(0): p1(3) = pTo(1)<BR>Set pPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(p1)<BR>Do While True<BR>pTo = ThisDrawing.Utility.GetPoint(pTo, vbCr & "请输入下一点：")<BR>p2(0) = pTo(0): p2(1) = pTo(1)<BR>pPL.AddVertex (UBound(pPL.Coordinates) + 1) / 2, p2<BR>Loop<BR>ErrHandle:<BR>End Sub</FONT> 谢谢！
那请问再如何将 SelectByPolygon应用到程序中选择该区域呢？ Sub Test()<BR>Dim ssetObj As AcadSelectionSet<BR>Dim CC As AcadCircle<BR>Dim points(0 To 59) As Double<BR>Dim retCoord As Variant
<BR>On Error Resume Next<BR>Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SSET2")
On Error GoTo ErrHandle<BR>Dim pFrom, pTo<BR>Dim p1(3) As Double, p2(1) As Double<BR>Dim pPL As AcadLWPolyline<BR>pFrom = ThisDrawing.Utility.GetPoint(, vbCr & "请输入第一点：")<BR>pTo = ThisDrawing.Utility.GetPoint(pFrom, vbCr & "请输入下一点：")<BR>p1(0) = pFrom(0): p1(1) = pFrom(1)<BR>p1(2) = pTo(0): p1(3) = pTo(1)<BR>Set pPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(p1)<BR>Do While True<BR>pTo = ThisDrawing.Utility.GetPoint(pTo, vbCr & "请输入下一点：")<BR>p2(0) = pTo(0): p2(1) = pTo(1)<BR>pPL.AddVertex (UBound(pPL.Coordinates) + 1) / 2, p2<BR>Loop<BR>ErrHandle:<BR>pPL.Closed = True
'points = pPL.Coordinates<BR>retCoord = pPL.Coordinates
ssetObj.SelectByPolygon acSelectionSetCrossingPolygon, retCoord
<BR>For Each CC In ssetObj
On Error Resume Next
CC.color = acBlue<BR>CC.Update
<BR>Next CC
<BR>ssetObj.Clear<BR>ssetObj.Erase<BR>ssetObj.Delete
<BR>End Sub
为什么会在ssetObj.SelectByPolygon acSelectionSetCrossingPolygon, retCoord无法编译过去，请大侠帮我指正，谢谢！
页:
[1]