两点之间沿多段线的距离
当然，在lisp中，可以使用vlax curve getDistAtPoint关于如何在VBA中实现这一点，最近有什么进展吗  
TIA
如果你还记得Frank Oquendo….他为那些仍在VBA中的人写了一个名为VLAX Curve class的东西，这里有一条捷径可以抓住它：[更多提示，这是一个zip文件][和….hth]http://discussion.autodesk.com/thread.jspa?threadID=502098 谢谢李。效果很好
这里是#039；这是一种Vba方式，它比我想象的要难一些，因为我已经有了它#039；s mate，在距离处获取点。
Option Explicit
Const PI As Double = 3.14159265358979
Sub TestPt()
Dim oPline As AcadLWPolyline
Dim Util As AcadUtility
Dim Varpick As Variant
Set Util = ThisDrawing.Utility
Util.GetEntity oPline, Varpick, "Pick a poly:"
Varpick = ThisDrawing.Utility.GetPoint(, "Point on poly")
Debug.Print LengthAtPointOnPoly(oPline, Varpick)
End Sub
Function LengthAtPointOnPoly(oPline As AcadLWPolyline, Varpick As Variant) As Double
Dim Dist As Double, TotalDist As Double
Dim dBulge As Double, seg As Double
Dim Pt(1) As Double
Dim C1, C2
Dim Ct As Integer, i As Long
Dim Util As AcadUtility
Set Util = ThisDrawing.Utility
Varpick = Util.TranslateCoordinates(Varpick, acWorld, acOCS, False, oPline.Normal)
If Not Rd(Varpick(2), oPline.Elevation) Then Exit Function
Pt(0) = Varpick(0): Pt(1) = Varpick(1)
Ct = (UBound(oPline.Coordinates) - 1) / 2
If oPline.Closed = True Then Ct = Ct + 1
ReDim Coords(Ct) As Variant
For i = 0 To Ct - 1
Coords(i) = oPline.Coordinate(i)
Next
If oPline.Closed = True Then
Coords(Ct) = oPline.Coordinate(0)
Else
Coords(Ct) = oPline.Coordinate(Ct)
End If
For i = 0 To Ct - 1
C1 = Coords(i)
C2 = Coords(i + 1)
dBulge = oPline.GetBulge(i)
seg = Length(C1, C2)
If dBulge = 0 Then
If isOnLine(C1, C2, Pt) Then
TotalDist = TotalDist + Length(C1, Pt)
Exit For
Else
TotalDist = TotalDist + seg
If i = Ct - 1 Then TotalDist = 0
End If
Else
If isPtonArc(C1, C2, Pt, dBulge, seg, Dist) Then
TotalDist = TotalDist + Dist
Exit For
Else
TotalDist = TotalDist + polyarclength(dBulge, seg)
If i = Ct - 1 Then TotalDist = 0
End If
End If
Next i
LengthAtPointOnPoly = TotalDist
End Function
Private Function isPtonArc(C1 As Variant, C2 As Variant, Pt As Variant, _
dBulge As Double, seg As Double, Dist As Double) As Boolean
Dim Rad As Double
Dim X As Double, Y As Double
Dim deltaX As Double, deltaY As Double
Dim Slope As Double, Invertslope As Double
Dim dLength As Double, AngX As Double
Dim CenPt(1) As Double
Dim bOnArc As Boolean
Dim iLeft As Integer
'IncludedAng = Atn(dBulge) * 4 'converting bulge to angle in radians
Rad = seg / (2 * Sin(2 * Atn(dBulge)))
'find the midpoint
X = (C1(0) + C2(0)) / 2
Y = (C1(1) + C2(1)) / 2
deltaX = C2(0) - C1(0)
deltaY = C2(1) - C1(1)
'Convert floating point to zero
If Rd(deltaX, 0) Then deltaX = 0
If Rd(deltaY, 0) Then deltaY = 0
'The height of the curve is dBulge * 0.5 * seg
'dist is the length from the midpoint to the center
Dist = Rad - dBulge * 0.5 * seg
'If Abs(dBulge) > 1 Then Dist = -Dist
If deltaY >= 0 Then
If deltaX0 Then
Dist = -Dist
End If
Else
If deltaX = 0 Then
Dist = -Dist
End If
End If
If deltaY = 0 Then'Line p1,p2 is horizontal
CenPt(0) = X
CenPt(1) = Y - Dist
ElseIf deltaX = 0 Then 'Line p1,p2 is vertical
CenPt(0) = X - Dist
CenPt(1) = Y
Else
Slope = deltaY / deltaX
Invertslope = -1 / Slope
'Invert slope for perpendicular bisector
'X = X1 + distance / dLength * DX
'proving for DeltaX=1 in slope direction
'slope=DeltaY / 1 =>DeltaY=slope
dLength = Sqr(Invertslope ^ 2 + 1)
CenPt(0) = X + (Dist / dLength) '* 1
CenPt(1) = Y + ((Dist / dLength) * Invertslope)
End If
AddPt CenPt, , 1
If Not Rd(Abs(Rad), Length(CenPt, Pt)) Then
Exit Function
'Point must be on a different segment
End If
iLeft = isLeft(C1, C2, Pt)
If dBulge > 0 Then
If iLeft-1 Then 'On line (0) or cw
bOnArc = True
End If
End If
If bOnArc = True Then
Dim C1pt As Double, incAng As Double
C1pt = 0.5 * Length(C1, Pt)
incAng = Abs(2 * ArcSin(C1pt / Rad))
If Sgn(isLeft(C1, CenPt, Pt)) = Sgn(dBulge) Then
incAng = 2 * PI - incAng
End If
Dist = Abs(incAng * Rad)
isPtonArc = True
End If
End Function
Private Function isOnLine(C1, C2, Pt) As Boolean
Dim deltaX As Double, deltaY As Double
Dim dLength As Double
Dim XY As Integer
Dim X As Double, Y As Double
If isLeft(C1, C2, Pt)0 Then Exit Function
deltaX = C2(0) - C1(0)
deltaY = C2(1) - C1(1)
If Rd(deltaX, 0) Then deltaX = 0
If Rd(deltaY, 0) Then deltaY = 0
If deltaX = 0 Then XY = 0 'Line p1,p2 is vertical
If deltaY = 0 Then XY = 1 'Line p1,p2 is horizontal
If deltaX = 0 Or deltaY = 0 Then
If C2(XY) > C1(XY) Then
If Pt(XY) >= C1(XY) And Pt(XY) = C2(XY) And Pt(XY) = -0.0000001 Then
If X = -0.0000001 And Y0 Then
Stx = StartPoint(0): Sty = StartPoint(1)
Enx = EndPoint(0): Eny = EndPoint(1)
dX = Stx - Enx
dY = Sty - Eny
If i = 1 Then
Length = Sqr(dX * dX + dY * dY)
Else
Stz = StartPoint(2): Enz = EndPoint(2)
dZ = Stz - Enz
Length = Sqr((dX * dX) + (dY * dY) + (dZ * dZ))
End If
Else
Exit Function
End If
Else
Exit Function
End If
End Function
Public Function polyarclength(Bulge As Double, LengthBetweenPts As Double) As Double
'Bulge is the getbulge & LengthBetweenPts is the straight dist. between 2 verticies
Dim dAng As Double, Dist As Double
dAng = Atn(Bulge) * 4 'converting bulge to angle in radians
Dist = 0.5 * LengthBetweenPts
polyarclength = dAng * Dist / Sin(0.5 * dAng)
End Function
Public Function ArcSin(X) As Double
If Abs(X > 1) Then
MsgBox "Oops"
End If
If X = 1 Then
ArcSin = PI * 0.5
ElseIf X = -1 Then
ArcSin = -PI * 0.5
Else
ArcSin = Atn(X / Sqr(-X * X + 1))
End If
End Function
Function isLeft(LineStart, LineEnd, Pt) As Integer
Dim Ans As Double
Ans = ((LineEnd(0) - LineStart(0)) * (Pt(1) - LineStart(1)) _
- (Pt(0) - LineStart(0)) * (LineEnd(1) - LineStart(1)))
Ans = Round(Ans, 12)
If Ans > 0 Then isLeft = 1: Exit Function'Pt is left of the line(CW)
If Ans < 0 Then isLeft = -1: Exit Function'Pt is right of the line (CCW)
If Ans = 0 Then isLeft = 0
End Function
页:
[1]