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

torch · 发表于 2004-8-3 17:29:00

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

ntchjie · 发表于 2004-8-3 20:33:00

这是一个获取逐点坐标计算面积的子程序，不知道合不合你的用？我在这里限制了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 · 发表于 2004-8-4 08:32:00

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 · 发表于 2004-8-4 16:36:00

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

torch · 发表于 2004-8-4 20:20:00

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无法编译过去，请大侠帮我指正，谢谢！

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

发表回复

精选推荐

浏览过的版块