|
|
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
' 计算点到直线的最短距离
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就有了。请高手看是怎么回事？多谢 |
|
置顶卡
