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