[分享]：点到多段线的最短距离，不收币

yj821005

变量名字不是很规范，呵呵！代码直接公开了，不收币！有没有积分啊！（开玩笑的，不过好期望啊！嘻嘻！没有也没关系，最主要是学习为主！）*-*5 *-*5 *-*5 *-*5
Option Explicit

Public Function disPtLw(p1() As Double, aa As AcadLWPolyline) As Double

    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 = aa
   
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
   
    If disPtline < mindisPtline Then
        mindisPtline = disPtline
    End If
        
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
        '最短距离
        If disPtline < mindisPtline Then
            mindisPtline = disPtline
        End If
End If

Next

disPtLw = mindisPtline
End Function

ps122

不错，学习了很多，谢谢！

yj821005

不好意思，我的代码发现有问题了，主要是判断点在不在线段中间，和判断点在不在圆弧的扇形区域有问题，现改正了，测试没问题了！
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

舟自横

如果是学习为主的话,我觉得是很不错的,
但是讲到实用好象VLISP中有VLAX-CURVE-GETCLOSEDPOINTTO
这么一个函数直接返回点到曲线的最短距离.....
呵呵.....

yj821005

楼上的：我的是CAD2002，VBA里面没有VLAX类型库啊！知道哪里有下还是怎么得来啊

舟自横

不在VBA里面在VISUAL LISP里面有的,CAD自带的你
可以在VLISP环境下加一句(VL-LOAD-COM)就可以了!

lixd17820

学一学,谢谢.

Newbuser

上学时的vb现在都忘记了，唯一记住的就只有vb二字了。