Geo Desic Curve

Option Explicit

Sub GeodesicUphillHiker()
 Dim strSrf, Pt1, Pt2
 Dim ptProject, uvClosest
 Dim arrPts(), crvID, crvType
 Dim numSamples, vecT
 Dim strResult

 strSrf = Rhino.GetObject("Select a surface to use...", 8, vbTrue)
 If IsNull(strSrf) Then Exit Sub
 Pt1 = Rhino.GetPointOnSurface (strSrf, "Pick a point on the surface to start hiking...")
 If IsNull(Pt1) Then Exit Sub
 Rhino.Prompt ""
 Pt2 = Rhino.GetPointOnSurface (strSrf, "Pick a goalpoint on the surface...")
 If IsNull(Pt2) Then Exit Sub

 numSamples = Rhino.GetReal("Specify a stepsize to use...", _
         Round(Rhino.Distance(Pt1, Pt2)/50, 1), _
         Rhino.UnitAbsoluteTolerance, _
         Round(Rhino.Distance(Pt1, Pt2)/5,1))
 If IsNull(numSamples) Then Exit Sub

 ReDim arrPts(0)
 arrPts(0) = Pt1
 ptProject = Pt1
 Do
  vecT = Array(ptProject, Pt2)
  If FastDistance(ptProject, Pt2) < numSamples Then
   ReDim Preserve arrPts(UBound(arrPts)+1)
   arrPts(UBound(arrPts)) = Pt2
   Exit Do
  Else
   vecT = ResizeVector(vecT, numSamples)
   uvClosest = Rhino.SurfaceClosestPoint(strSrf, vecT(1))
   ptProject = Rhino.EvaluateSurface(strSrf, uvClosest)
   ReDim Preserve arrPts(UBound(arrPts)+1)
   arrPts(UBound(arrPts)) = ptProject
   Rhino.Prompt UBound(arrPts) & " samples solved..."
   If FastDistance(arrPts(UBound(arrPts)), arrPts(UBound(arrPts)-1)) < Rhino.UnitAbsoluteTolerance/2 Then Exit Do
  End If
 Loop

 Rhino.EnableRedraw False
  crvID = Rhino.AddInterpCurve(arrPts)
  Rhino.ObjectName crvID, "Geodesic (" & Round(Rhino.CurveLength(crvID),3) & ")"
 Rhino.EnableRedraw True

 Rhino.Print "Finished"
End Sub
GeodesicUphillHiker

Function FastDistance(Byval arrPt1, Byval arrPt2)
 FastDistance = (arrPt1(0)-arrPt2(0)) * (arrPt1(0)-arrPt2(0)) + _
       (arrPt1(1)-arrPt2(1)) * (arrPt1(1)-arrPt2(1)) + _
       (arrPt1(2)-arrPt2(2)) * (arrPt1(2)-arrPt2(2))
 FastDistance = Sqr(FastDistance)
End Function

´This function will resize an existing vector to fit a new length
Function ResizeVector(Byval vecIn, byval newLength)
 Dim vecOut, d, i
 vecOut = CopyVector(vecIn)
 If IsVectorNull(vecIn) Then Exit Function
 d = VectorLength(vecIn)
 For i = 0 to 2
  vecOut(1)(i) = vecIn(0)(i) + (vecIn(1)(i)-vecIn(0)(i))/d*newLength
 Next
 ResizeVector = vecOut
End Function

´This function will copy an existing vector
Function CopyVector(Byval vecIn)
 Dim vecOut
 vecOut = Array(vecIn(0), vecIn(1))
 CopyVector = vecOut
End Function

´This function will check if a vector has no length
Function IsVectorNull(Byval vecIn)
 If (vecIn(0)(0) = vecIn(1)(0)) And _
    (vecIn(0)(1) = vecIn(1)(1)) And _
    (vecIn(0)(2) = vecIn(1)(2)) Then
  IsVectorNull = vbTrue
 Else
  IsVectorNull = vbFalse
 End If
End Function

´This Function will return the length of a vector
Function VectorLength(Byval vecIn)
 VectorLength = Rhino.Distance(vecIn(0), vecIn(1))
End Function

Ekleyen: Mad_Max