[分享]给一个点和一段多段线，求出这个点到多段线的最短距离吗？

yj821005

[求助]有谁用VBA写过给一个点和一段多段线，求出这个点到多段线的最短距离吗？好写但是现在我还有其他的问题很忙，不晓得有没有哪位好心人写过（我觉得应该有人碰到过这个问题）

yj821005

自己写了，不晓得对不对！请明总看看，还有就是我的变量名字可能不是很规范！ Option Explicit Sub disPtLwline() Dim disPtline As Double
Dim mindisPtline As Double
Dim p1 As Variant
Dim p2(0 To 2) As Double
p1 = ThisDrawing.Utility.GetPoint(, " 请输入点：")
p2(0) = p1(0): p2(1) = p1(1): p2(2) = 0
Dim objPline As AcadLWPolyline
Dim mlwlineqidian1 As AcadEntity
Dim mlwlineqidian2 As Variant
ThisDrawing.Utility.GetEntity mlwlineqidian1, mlwlineqidian2, "请选择多段线"
If TypeOf mlwlineqidian1 Is AcadLWPolyline Then
Set objPline = mlwlineqidian1
End If



Dim intVCnt As Integer
Dim varCords As Variant
Dim varVert As Variant
Dim varCord As Variant
Dim varNext As Variant
Dim intCrdCnt As Integer
Dim dblXSl As Double
Dim dblYSl As Double
Dim dblZSl As Double
Dim dblTemp As Double
Dim dblTemp1 As Double
Dim dblTemp2 As Double
Dim dblAng As Double
Dim dblChord As Double
Dim dblInclAng As Double
Dim dblRad As Double
Dim intDiv As Integer
Dim houdian As Variant
Dim houdian1(0 To 1) As Double
Dim qiandian As Variant
Dim qiandian1(0 To 1) As Double
intDiv = 2
varCords = objPline.Coordinates
For Each varVert In varCords
intVCnt = intVCnt + 1
Next For intCrdCnt = 0 To intVCnt / intDiv - 1
If intCrdCnt < intVCnt / intDiv - 1 Then
varCord = objPline.Coordinate(intCrdCnt)
varNext = objPline.Coordinate(intCrdCnt + 1)
ElseIf objPline.Closed Then
varCord = objPline.Coordinate(intCrdCnt)
varNext = objPline.Coordinate(0)
Else
Exit For
End If
dblXSl = (varCord(0) - varNext(0)) ^ 2
dblYSl = (varCord(1) - varNext(1)) ^ 2
houdian = objPline.Coordinate(intCrdCnt + 1)
houdian1(0) = houdian(0): houdian1(1) = houdian(1)
qiandian = objPline.Coordinate(intCrdCnt)
qiandian1(0) = qiandian(0): qiandian1(1) = qiandian(1)

If objPline.GetBulge(intCrdCnt) = 0 Then '当这段线是直线的时候
Dim testdata As Double
dblTemp = Sqr(dblXSl + dblYSl)
dblTemp1 = disliangdian(p2(0), p2(1), qiandian1(0), qiandian1(1))
dblTemp2 = disliangdian(p2(0), p2(1), houdian1(0), houdian1(1))
disPtline = Sqr(dblTemp1 ^ 2 - ((dblTemp ^ 2 + dblTemp1 ^ 2 - dblTemp2 ^ 2) ^ 2) / (4 * dblTemp ^ 2))
testdata = dblTemp ^ 2 + dblTemp1 ^ 2 - dblTemp2 ^ 2 '判断点与直线的关系，是不是在直线两个端点之间。

If intCrdCnt = 0 Then '给最短距离一个初始化的值
mindisPtline = dblTemp1
End If

If testdata < 0 Then '如果点在两个端点之外，距离为到端点距离的最小值
disPtline = dblTemp1
If dblTemp2 < dblTemp1 Then
disPtline = dblTemp2
End If
End If
MsgBox "这短直线中最短距离为： " & disPtline

If disPtline < mindisPtline Then
mindisPtline = disPtline
End If

MsgBox "目前最短距离为： " & mindisPtline
Else '不是直线
'if there is a bulge we need to get an arc length
dblChord = Sqr(dblXSl + dblYSl)
dblInclAng = Atn(Abs(objPline.GetBulge(intCrdCnt))) * 4
dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2)
dblRad = (dblChord / 2) / (Cos(dblAng))
'dblArc = dblInclAng * dblRad
dblTemp1 = disliangdian(p2(0), p2(1), qiandian1(0), qiandian1(1))
dblTemp2 = disliangdian(p2(0), p2(1), houdian1(0), houdian1(1))


Dim fuzhuhu As AcadLWPolyline
Dim fuzhuhu1(0 To 3) As Double
Dim fuzhuhu2 As AcadArc
Dim fuzhuhu3 As Variant
Dim fuzhuhu4(0 To 2) As Double
Dim fuzhuhu5 As Variant
Dim qianangle As Double
Dim houangle As Double
Dim ceshidian As Variant fuzhuhu1(0) = qiandian(0)
fuzhuhu1(1) = qiandian(1)
fuzhuhu1(2) = houdian(0)
fuzhuhu1(3) = houdian(1)
Set fuzhuhu = ThisDrawing.ModelSpace.AddLightWeightPolyline(fuzhuhu1)
fuzhuhu.SetBulge 0, objPline.GetBulge(intCrdCnt)
fuzhuhu5 = fuzhuhu.Explode
If TypeOf fuzhuhu5(0) Is AcadArc Then
Set fuzhuhu2 = fuzhuhu5(0)
End If
'确定弧的圆心
fuzhuhu3 = fuzhuhu2.Center
fuzhuhu4(0) = fuzhuhu3(0): fuzhuhu4(1) = fuzhuhu3(1): fuzhuhu4(2) = 0
'确定弧的起始角度
ceshidian = fuzhuhu2.StartPoint
If Abs(ceshidian(0) - qiandian(0)) < zero1 And Abs(ceshidian(1) - qiandian(1)) < zero1 Then
qianangle = fuzhuhu2.StartAngle
houangle = fuzhuhu2.EndAngle
Else
qianangle = fuzhuhu2.EndAngle
houangle = fuzhuhu2.StartAngle
End If
'删除辅助的圆弧
fuzhuhu2.Delete
fuzhuhu.Delete
'判断点是不是在圆弧所在扇形区域内
Dim fuzhuline As AcadLine
Dim dblAngledian As Double
Set fuzhuline = ThisDrawing.ModelSpace.AddLine(fuzhuhu4, p2)
dblAngledian = fuzhuline.Angle

disPtline = Abs(dblRad - fuzhuline.Length)
If intCrdCnt = 0 Then '给最短距离一个初始化的值
mindisPtline = dblTemp1
End If
fuzhuline.Delete
'不在圆弧的扇形区域时的最短距离
If (dblAngledian - qianangle) * (dblAngledian - houangle) > zero1 Then
disPtline = dblTemp1
If dblTemp2 < dblTemp1 Then
disPtline = dblTemp2
End If
End If
MsgBox "圆弧中最短长度是： " & disPtline
'最短距离
If disPtline < mindisPtline Then
mindisPtline = disPtline
End If
MsgBox "目前最短距离为： " & mindisPtline
End If Next MsgBox "最终最短距离为： " & mindisPtline
End Sub

yj821005

sorry！我的代码发现有问题了，主要是判断点在不在线段中间，和判断点在不在圆弧的扇形区域有问题，现改正了，测试没问题了！把它做成了函数，后面附了测试的代码： Option Explicit

Public Function disPtLw(p1() As Double, aa As AcadEntity) As Double
'先将直线、圆弧、圆都转化为多段线
Dim mEntzhuan As AcadEntity
Set mEntzhuan = aa
Dim mLwlines As AcadLWPolyline '辅助的多段线，将所有的线都变成多段线
If TypeOf mEntzhuan Is AcadLWPolyline Then
Dim mfuzhuLw() As Object
mfuzhuLw() = mEntzhuan.Offset(zero1)
If TypeOf mfuzhuLw(0) Is AcadLWPolyline Then
Set mLwlines = mfuzhuLw(0)
End If
ElseIf TypeOf mEntzhuan Is AcadArc Then
Dim x As Double
Dim hu2 As AcadArc
Set hu2 = mEntzhuan
x = Tan(hu2.TotalAngle / 4)
ep(0) = hu2.StartPoint(0)
ep(1) = hu2.StartPoint(1)
ep(2) = hu2.EndPoint(0)
ep(3) = hu2.EndPoint(1)
Set mLwlines = ThisDrawing.ModelSpace.AddLightWeightPolyline(ep)
mLwlines.SetBulge 0, x
ElseIf TypeOf mEntzhuan Is AcadLine Then
Dim zhi2 As AcadLine
Set zhi2 = mEntzhuan
ap(0) = zhi2.StartPoint(0)
ap(1) = zhi2.StartPoint(1)
ap(2) = zhi2.EndPoint(0)
ap(3) = zhi2.EndPoint(1)
Set mLwlines = ThisDrawing.ModelSpace.AddLightWeightPolyline(ap)
ElseIf TypeOf mEntzhuan Is AcadCircle Then '对圆的处理
Dim yp(0 To 5) As Double
Dim yuan1 As AcadCircle
Set yuan1 = mEntzhuan
yp(0) = yuan1.Center(0) - yuan1.Radius
yp(1) = yuan1.Center(1)
yp(2) = yuan1.Center(0) + yuan1.Radius
yp(3) = yuan1.Center(1)
yp(4) = yuan1.Center(0) - yuan1.Radius
yp(5) = yuan1.Center(1)
Set mLwlines = ThisDrawing.ModelSpace.AddLightWeightPolyline(yp)
mLwlines.SetBulge 0, 1
mLwlines.SetBulge 1, 1
Else
MsgBox Err.Description
Exit Function
End If




'对多段线来算最短距离
Dim disPtline As Double
Dim mindisPtline As Double
Dim p2(0 To 2) As Double
p2(0) = p1(0): p2(1) = p1(1): p2(2) = 0
Dim objPline As AcadLWPolyline
Set objPline = mLwlines

Dim intVCnt As Integer
Dim varCords As Variant
Dim varVert As Variant
Dim varCord As Variant
Dim varNext As Variant
Dim intCrdCnt As Integer
Dim dblXSl As Double
Dim dblYSl As Double
Dim dblZSl As Double
Dim dblTemp As Double
Dim dblTemp1 As Double
Dim dblTemp2 As Double
Dim dblAng As Double
Dim dblChord As Double
Dim dblInclAng As Double
Dim dblRad As Double
Dim intDiv As Integer
Dim houdian As Variant
Dim houdian1(0 To 1) As Double
Dim qiandian As Variant
Dim qiandian1(0 To 1) As Double
intDiv = 2
varCords = objPline.Coordinates
For Each varVert In varCords
intVCnt = intVCnt + 1
Next

For intCrdCnt = 0 To intVCnt / intDiv - 1
If intCrdCnt < intVCnt / intDiv - 1 Then
varCord = objPline.Coordinate(intCrdCnt)
varNext = objPline.Coordinate(intCrdCnt + 1)
ElseIf objPline.Closed Then
varCord = objPline.Coordinate(intCrdCnt)
varNext = objPline.Coordinate(0)
Else
Exit For
End If
dblXSl = (varCord(0) - varNext(0)) ^ 2
dblYSl = (varCord(1) - varNext(1)) ^ 2
houdian = objPline.Coordinate(intCrdCnt + 1)
houdian1(0) = houdian(0): houdian1(1) = houdian(1)
qiandian = objPline.Coordinate(intCrdCnt)
qiandian1(0) = qiandian(0): qiandian1(1) = qiandian(1)

If objPline.GetBulge(intCrdCnt) = 0 Then '当这段线是直线的时候
Dim testdata As Double
Dim testdata1 As Double
dblTemp = Sqr(dblXSl + dblYSl)
dblTemp1 = disliangdian(p2(0), p2(1), qiandian1(0), qiandian1(1))
dblTemp2 = disliangdian(p2(0), p2(1), houdian1(0), houdian1(1))
disPtline = Sqr(dblTemp1 ^ 2 - ((dblTemp ^ 2 + dblTemp1 ^ 2 - dblTemp2 ^ 2) ^ 2) / (4 * dblTemp ^ 2))
testdata = Abs(dblTemp ^ 2 + dblTemp1 ^ 2 - dblTemp2 ^ 2) / (2 * dblTemp) '判断点与直线的关系，是不是在直线两个端点之间。
testdata1 = Abs(dblTemp ^ 2 - dblTemp1 ^ 2 + dblTemp2 ^ 2) / (2 * dblTemp)
If intCrdCnt = 0 Then '给最短距离一个初始化的值
mindisPtline = dblTemp1
End If

If testdata > dblTemp Or testdata1 > dblTemp Then '如果点在两个端点之外，距离为到端点距离的最小值
disPtline = dblTemp1
If dblTemp2 < dblTemp1 Then
disPtline = dblTemp2
End If
End If
'MsgBox "这段直线中最短距离为： " & disPtline
If disPtline < mindisPtline Then
mindisPtline = disPtline
End If
'MsgBox "目前最短距离为： " & mindisPtline
Else '不是直线
'if there is a bulge we need to get an arc length
dblChord = Sqr(dblXSl + dblYSl)
dblInclAng = Atn(Abs(objPline.GetBulge(intCrdCnt))) * 4
dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2)
dblRad = (dblChord / 2) / (Cos(dblAng))
'dblArc = dblInclAng * dblRad
dblTemp1 = disliangdian(p2(0), p2(1), qiandian1(0), qiandian1(1))
dblTemp2 = disliangdian(p2(0), p2(1), houdian1(0), houdian1(1))


Dim fuzhuhu As AcadLWPolyline
Dim fuzhuhu1(0 To 3) As Double
Dim fuzhuhu2 As AcadArc
Dim fuzhuhu3 As Variant
Dim fuzhuhu4(0 To 2) As Double
Dim fuzhuhu5 As Variant
Dim qianangle As Double
Dim houangle As Double
fuzhuhu1(0) = qiandian(0)
fuzhuhu1(1) = qiandian(1)
fuzhuhu1(2) = houdian(0)
fuzhuhu1(3) = houdian(1)
Set fuzhuhu = ThisDrawing.ModelSpace.AddLightWeightPolyline(fuzhuhu1)
fuzhuhu.SetBulge 0, objPline.GetBulge(intCrdCnt)
fuzhuhu5 = fuzhuhu.Explode
If TypeOf fuzhuhu5(0) Is AcadArc Then
Set fuzhuhu2 = fuzhuhu5(0)
End If
'确定弧的圆心
fuzhuhu3 = fuzhuhu2.Center
fuzhuhu4(0) = fuzhuhu3(0): fuzhuhu4(1) = fuzhuhu3(1): fuzhuhu4(2) = 0
'确定弧的起始角度
qianangle = fuzhuhu2.StartAngle
houangle = fuzhuhu2.EndAngle
'删除辅助的圆弧
fuzhuhu2.Delete
fuzhuhu.Delete
'判断点是不是在圆弧所在扇形区域内
Dim fuzhuline As AcadLine
Dim dblAngledian As Double
Set fuzhuline = ThisDrawing.ModelSpace.AddLine(fuzhuhu4, p2)
dblAngledian = fuzhuline.Angle

disPtline = Abs(dblRad - fuzhuline.Length)
If intCrdCnt = 0 Then '给最短距离一个初始化的值
mindisPtline = dblTemp1
End If
fuzhuline.Delete
'不在圆弧的扇形区域时的最短距离
If (dblAngledian - qianangle) * (dblAngledian - houangle) * (qianangle - houangle) < zero1 Then
disPtline = dblTemp1
If dblTemp2 < dblTemp1 Then
disPtline = dblTemp2
End If
End If
'MsgBox "圆弧中最短长度是： " & disPtline
'最短距离
If disPtline < mindisPtline Then
mindisPtline = disPtline
End If
'MsgBox "目前最短距离为： " & mindisPtline
End If

Next
objPline.Delete

disPtLw = mindisPtline
'MsgBox "最终最短距离为： " & mindisPtline
End Function






下面的是测试代码：
Sub ztest()
'点到多段线的最短距离
Dim disPtline As Double
Dim mindisPtline As Double
Dim p1 As Variant
Dim p2(0 To 1) As Double
p1 = ThisDrawing.Utility.GetPoint(, " 请输入点：")
p2(0) = p1(0): p2(1) = p1(1)
Dim objPline As AcadLWPolyline
Dim mlwlineqidian1 As AcadEntity
ThisDrawing.Utility.GetEntity mlwlineqidian1, mlwlineqidian2, "请选择多段线"
Dim x As Double
x = disPtLw(p2, mlwlineqidian1)
MsgBox "特斯他的长度为：" & x
End Sub

雪山飞狐_lzh

用Vlax类简单多了，还可求样条曲线的

cqy

运用中提示zero1未定义。

yj821005

sorry zero1是我其他地方用的就是一个0.0000001之类的。这边好像可以用0代替！ 另： lzh741206 斑竹好：我的是CAD2002，用VBA但是里面好像没有VLAX类型库，请问哪里有？能给我一份吗？？谢谢！QQ：5705560 E—mail：yujun821005@hotmail.com

yj821005

sorry，zero1是我在其他地方用到的，这边应该是用0。 另 lzh741206 斑竹：你好！我用的是CAD2002。用VBA作的，但是我里面好像没有VLAX类型库for vBA，从哪里能下到，你能给我一份吗？谢谢! qq:5705560 E-mail:yujun821005@hotmail.com

园子829

我觉得：可以直接用（斜率1*斜率2=-1） 算交点的办法，比你这个方法简单，我试过的