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

yj821005 发表于 2005-3-17 15:09:00

本帖最后由作者于 2005-3-22 16:53:12 编辑 [求助]有谁用VBA写过给一个点和一段多段线，求出这个点到多段线的最短距离吗？好写但是现在我还有其他的问题很忙，不晓得有没有哪位好心人写过（我觉得应该有人碰到过这个问题）

yj821005 发表于 2005-3-22 09:55:00

自己写了，不晓得对不对！请明总看看，还有就是我的变量名字可能不是很规范！

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 发表于 2005-3-24 09:58:00

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 发表于 2005-3-24 17:53:00

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

cqy 发表于 2005-3-31 14:16:00

运用中提示zero1未定义。

yj821005 发表于 2005-3-31 15:00:00

sorry zero1是我其他地方用的就是一个0.0000001之类的。这边好像可以用0代替！

另： <A name=17605>lzh741206</A> 斑竹好：我的是CAD2002，用VBA但是里面好像没有VLAX类型库，请问哪里有？能给我一份吗？？谢谢！QQ：5705560

E—mail：yujun821005@hotmail.com

yj821005 发表于 2005-3-31 15:03:00

sorry，zero1是我在其他地方用到的，这边应该是用0。

另 <A name=17605>lzh741206</A> 斑竹：你好！我用的是CAD2002。用VBA作的，但是我里面好像没有VLAX类型库for vBA，从哪里能下到，你能给我一份吗？谢谢!

qq:5705560 E-mail:yujun821005@hotmail.com

园子829 发表于 2005-3-31 23:12:00

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

页: [1]

明经CAD社区's Archiver

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