如何通过VBA获得CAD鼠标获得点来画Polyline并封闭形成多边形，形成完毕再返回执行程
如何通过VBA获得CAD鼠标获得点来画Polyline并封闭形成多边形，形成完毕再返回执行程序如何通过VBA获得CAD鼠标获得点来画Polyline并封闭形成多边形，形成完毕再返回执行程序 这是一个获取逐点坐标计算面积的子程序，不知道合不合你的用？我在这里限制了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
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 谢谢！
那请问再如何将 SelectByPolygon应用到程序中选择该区域呢？ 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无法编译过去，请大侠帮我指正，谢谢！
页:
[1]