求助：我在cad08或06里画的多段线怎么不支持对象
本帖最后由 作者 于 2009-4-24 13:18:01 编辑 <br /><br /> <p>Sub toudu()<br/>Dim pl(7) As Double</p><p>pt(2) as Double<br/>Dim plineObj As AcadLWPolyline<br/>pl(0) = 5.6811<br/>pl(1) = 0<br/>pl(2) = -5.6811<br/>pl(3) = 0<br/>pl(4) = -5.6811<br/>pl(5) = 0<br/>pl(6) = 5.6811<br/>pl(7) = 0<br/>Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pl)<br/>plineObj.SetBulge 0, 1.72677826<br/>plineObj.SetBulge 1, 0<br/>dim q as Double<br/> pt(0) = 4.470<br/> pt(1) = 7.921<br/> pt(2) = 0</p><p><font color="#f70909">q = DistancePt2Poly(pt1, plineObj)‘调用明经的点到多段线的最短距离<br/> MsgBox "点到多段线的最近距离是:" & q</font></p><p><font color="#f70909">end sub</font></p><p>Private Function DistancePt2Poly(ByVal pt As Variant, ByVal objPoly As AcadLWPolyline) As Double<br/> Dim intVertCount As Integer ' 多段线的顶点数量<br/> Dim varCoords As Variant ' 保存所有顶点的坐标数组<br/> varCoords = objPoly.Coordinates<br/> intVertCount = (UBound(varCoords) + 1) / 2<br/> <br/> ' 遍历所有顶点，判断每一段曲线与点之间的距离<br/> Dim i As Integer<br/> Dim ptCurrent As Variant, ptNext As Variant ' 当前顶点和下一个顶点<br/> Dim minDistance As Double ' 最短距离<br/> For i = 0 To intVertCount - 1<br/> ' 获得当前顶点和下一个顶点的坐标<br/> If i < intVertCount - 1 Then<br/> ptCurrent = objPoly.Coordinate(i)<br/> ptNext = objPoly.Coordinate(i + 1)<br/> ElseIf objPoly.Closed Then<br/> ptCurrent = objPoly.Coordinate(i)<br/> ptNext = objPoly.Coordinate(0)<br/> Else<br/> Exit For<br/> End If<br/> <br/> ' 分情况计算距离<br/> If objPoly.GetBulge(i) = 0 Then ' 如果该段是直线<br/> If i = 0 Then<br/> minDistance = DisPt2Line(pt, ptCurrent, ptNext)<br/> Else<br/> If DisPt2Line(pt, ptCurrent, ptNext) < minDistance Then<br/> minDistance = DisPt2Line(pt, ptCurrent, ptNext)<br/> End If<br/> End If<br/> Else<br/> Dim aimPoly As AcadLWPolyline ' 辅助多段线<br/> Dim ptVerts(0 To 3) As Double ' 辅助多段线的顶点<br/> Dim varEnts As Variant ' 分解辅助多段线后得到的实体<br/> Dim aimArc As AcadArc ' 辅助圆弧<br/> ptVerts(0) = ptCurrent(0)<br/> ptVerts(1) = ptCurrent(1)<br/> ptVerts(2) = ptNext(0)<br/> ptVerts(3) = ptNext(1)<br/> Set aimPoly = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptVerts)<br/> aimPoly.SetBulge 0, objPoly.GetBulge(i)<br/> <br/> ' 分解辅助多段线，得到一个圆弧<br/> varEnts = aimPoly.Explode<br/> If TypeOf varEnts(0) Is AcadArc Then<br/> Set aimArc = varEnts(0)<br/> End If<br/> <br/> ' 计算点到圆弧段的距离<br/> If i = 0 Then<br/> minDistance = DisPt2Arc(pt, aimArc)<br/> Else<br/> If DisPt2Arc(pt, aimArc) < minDistance Then<br/> minDistance = DisPt2Arc(pt, aimArc)<br/> End If<br/> End If<br/> <br/> ' 删除辅助圆弧和多段线<br/> aimPoly.Delete<br/> aimArc.Delete<br/> End If<br/> Next i<br/> <br/> DistancePt2Poly = minDistance<br/>End Function</p><p>' 计算点到直线的最短距离<br/>Private Function DisPt2Line(ByVal pt As Variant, ByVal ptStart As Variant, _<br/> ByVal ptEnd As Variant) As Double<br/> ' 计算三点所组成的三角形的面积s=sqr(p*(p-a)*(p-b)*(p-c))，p=0.5*(a+b+c)<br/> Dim area As Double<br/> Dim p As Double ' 周长的一半<br/> Dim a As Double, b As Double, c As Double ' 各条边的边长<br/> a = Distance(pt, ptStart)<br/> b = Distance(pt, ptEnd)<br/> c = Distance(ptStart, ptEnd)<br/> p = (a + b + c) / 2<br/> area = Sqr(p * (p - a) * (p - b) * (p - c))<br/> <br/> ' 计算点到直线的垂直距离<br/> Dim dblDistance As Double<br/> dblDistance = 2 * area / c<br/> <br/> ' 计算垂足到直线两端点的距离<br/> Dim dblDis1 As Double, dblDis2 As Double<br/> dblDis1 = Sqr(a ^ 2 - dblDistance ^ 2)<br/> dblDis2 = Sqr(b ^ 2 - dblDistance ^ 2)<br/> <br/> ' 根据点是否在直线两端点之间，返回点到直线的最短距离<br/> If dblDis1 > c Or dblDis2 > c Then<br/> If a > b Then<br/> DisPt2Line = b<br/> Else<br/> DisPt2Line = a<br/> End If<br/> Else<br/> DisPt2Line = dblDistance<br/> End If<br/>End Function</p><p>' 计算点到圆弧的最短距离<br/>Private Function DisPt2Arc(ByVal pt As Variant, ByVal objArc As AcadArc) As Double<br/> ' 假设点在圆弧的扇形区域内，返回点到圆弧的距离<br/> DisPt2Arc = Distance(pt, objArc.Center) - objArc.Radius<br/> <br/> ' 计算点到圆弧两个端点的距离<br/> Dim dblDis1 As Double, dblDis2 As Double<br/> dblDis1 = Distance(pt, objArc.StartPoint)<br/> dblDis2 = Distance(pt, objArc.EndPoint)<br/> <br/> ' 如果点不在圆弧的扇形区域内，则到两端点的距离包含了一个最小距离<br/> Dim angle As Double ' 圆心到点的矢量的角度<br/> angle = ThisDrawing.Utility.AngleFromXAxis(objArc.Center, pt)<br/> Dim angleStart As Double, angleEnd As Double<br/> angleStart = objArc.StartAngle<br/> angleEnd = objArc.EndAngle<br/> If (angle - angleStart) * (angle - angleEnd) * (angleEnd - angleStart) > ZERO Then<br/> If dblDis1 > dblDis2 Then<br/> DisPt2Arc = dblDis2<br/> Else<br/> DisPt2Arc = dblDis1<br/> End If<br/> End If<br/>End Function</p><p>' 计算两点之间的距离<br/>Private Function Distance(ByVal pt1 As Variant, ByVal pt2 As Variant) As Double<br/> Distance = Sqr((pt1(0) - pt2(0)) ^ 2 + (pt1(1) - pt2(1)) ^ 2)<br/>End Function</p><p>' 测试本节的函数<br/>Sub GetDistancePt2Poly()<br/> Dim pt As Variant<br/> pt = ThisDrawing.Utility.GetPoint(, "拾取一点:")</p><p> Dim objPoly As AcadLWPolyline<br/> Dim ptPick As Variant<br/> ThisDrawing.Utility.GetEntity objPoly, ptPick, "选择多段线:"<br/> <br/> MsgBox "点到多段线的最近距离是:" & DistancePt2Poly(pt, objPoly)<br/>End Sub</p><p><br/></p><p>怎么q的值是空值，要呢显示错误：（溢出）调试了好久就没有，但是在命令行用pline画一个，用哪个测试函数GetDistancePt2Poly就有了。请高手看是怎么回事？多谢</p>
页:
[1]