如何通过VBA获得CAD鼠标获得点来画Polyline并封闭形成多边形，形成完毕再返回执行程

torch

如何通过VBA获得CAD鼠标获得点来画Polyline并封闭形成多边形，形成完毕再返回执行程序[br]如何通过VBA获得CAD鼠标获得点来画Polyline并封闭形成多边形，形成完毕再返回执行程序

ntchjie

这是一个获取逐点坐标计算面积的子程序，不知道合不合你的用？我在这里限制了20个点，先生成了一个polyline，然后获取面积，最后删除物体，也许对你没有，写的不好，高手见笑。 Public Sub getab()
'获得逐点面积
Dim p() As Double
Dim p1 As Variant
Dim i As Integer
Dim polyl As Object On Error GoTo err:
Call AcadOpen
Set acadutil = acadObj.ActiveDocument.utility

AppActivate "Autocad" ' For i = 0 To 59 Step 3
p1 = acadutil.Getpoint(, "输入欲调查面积的控制点... ")
ReDim Preserve p(i + 2)
p(i) = p1(0): p(i + 1) = p1(1): p(i + 2) = 0

Next i
err:
If err.Number = -2145320928 Or err.Number = -2145320851 Then

Set polyl = acadObj.ActiveDocument.ModelSpace.AddPolyline(p)
grid.Text = Round(polyl.Area, sn)
polyl.Delete
Else:
Exit Sub
End If End Sub

雪山飞狐_lzh

Sub Test()
On Error GoTo ErrHandle
Dim pFrom, pTo
Dim p1(3) As Double, p2(1) As Double
Dim pPL As AcadLWPolyline
pFrom = ThisDrawing.Utility.GetPoint(, vbCr & "请输入第一点：")
pTo = ThisDrawing.Utility.GetPoint(pFrom, vbCr & "请输入下一点：")
p1(0) = pFrom(0): p1(1) = pFrom(1)
p1(2) = pTo(0): p1(3) = pTo(1)
Set pPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(p1)
Do While True
pTo = ThisDrawing.Utility.GetPoint(pTo, vbCr & "请输入下一点：")
p2(0) = pTo(0): p2(1) = pTo(1)
pPL.AddVertex (UBound(pPL.Coordinates) + 1) / 2, p2
Loop
ErrHandle:
End Sub

torch

谢谢！


那请问再如何将 SelectByPolygon应用到程序中选择该区域呢？

torch

Sub Test()
Dim ssetObj As AcadSelectionSet
Dim CC As AcadCircle
Dim points(0 To 59) As Double
Dim retCoord As Variant
On Error Resume Next
Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SSET2") On Error GoTo ErrHandle
Dim pFrom, pTo
Dim p1(3) As Double, p2(1) As Double
Dim pPL As AcadLWPolyline
pFrom = ThisDrawing.Utility.GetPoint(, vbCr & "请输入第一点：")
pTo = ThisDrawing.Utility.GetPoint(pFrom, vbCr & "请输入下一点：")
p1(0) = pFrom(0): p1(1) = pFrom(1)
p1(2) = pTo(0): p1(3) = pTo(1)
Set pPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(p1)
Do While True
pTo = ThisDrawing.Utility.GetPoint(pTo, vbCr & "请输入下一点：")
p2(0) = pTo(0): p2(1) = pTo(1)
pPL.AddVertex (UBound(pPL.Coordinates) + 1) / 2, p2
Loop
ErrHandle:
pPL.Closed = True 'points = pPL.Coordinates
retCoord = pPL.Coordinates ssetObj.SelectByPolygon acSelectionSetCrossingPolygon, retCoord
For Each CC In ssetObj On Error Resume Next CC.color = acBlue
CC.Update
Next CC
ssetObj.Clear
ssetObj.Erase
ssetObj.Delete
End Sub 为什么会在ssetObj.SelectByPolygon acSelectionSetCrossingPolygon, retCoord无法编译过去，请大侠帮我指正，谢谢！