Close Open Curves

Option Explicit

Sub CloseOpenCurves()
 Dim allCurves, i, j
 Dim blnLine, blnJoin
 Dim strResult, arrOptions(3)
 Dim addCurves()

 blnJoin = Rhino.GetSettings(Rhino.InstallFolder & "Gelfling.ini", "CloseOpenCurves", "Join")
 If IsNull(blnJoin) Then blnJoin = vbFalse Else blnJoin = CBool(blnJoin)
 blnLine = Rhino.GetSettings(Rhino.InstallFolder & "Gelfling.ini", "CloseOpenCurves", "Line")
 If IsNull(blnLine) Then blnLine = vbTrue Else blnLine = CBool(blnLine)

 allCurves = Rhino.GetObjects("Select curves to close...", 4, vbFalse, vbTrue, vbTrue)
 If IsNull(allCurves) Then Exit Sub
 ReDim addCurves(UBound(allCurves))
 j=0
 Rhino.EnableRedraw vbFalse
 For i=0 To UBound(allCurves)
  If Rhino.IsCurveClosed(allCurves(i)) Or Rhino.IsCurveLinear(allCurves(i)) Then
   Rhino.UnselectObject allCurves(i)
   allCurves(i) = "Nothing"
   addCurves(i) = "Nothing"
   j=j+1
  End If
 Next
 If j = UBound(allCurves)+1 Then Rhino.Print "No closable curves could be salvaged from the selection." : Exit Sub
 If j=1 Then Rhino.Print "1 linear or closed curve has been exluded from the selection."
 If j>1 Then Rhino.Print j & " linear and/or closed curves have been excluded from the selection."

 Rhino.EnableRedraw vbFalse
 For i = 0 To UBound(allCurves)
  addCurves(i) = CloseOpenCurve(allCurves(i), blnLine, blnJoin)
 Next
 Rhino.EnableRedraw vbTrue

 Do
  arrOptions(0) = "Join_No"
  arrOptions(1) = "Tangency"
  If blnJoin Then arrOptions(0) = "Join_Yes"
  If blnLine Then arrOptions(1) = "Position"
  arrOptions(2) = "Accept"
  arrOptions(3) = "Quit"
  strResult = Rhino.GetString("", "Accept", arrOptions)
  If IsNull(strResult) Then Exit Sub
  Select Case UCase(Left(strResult, 1))
  Case "J"
   blnJoin = Not blnJoin
   Rhino.DeleteObjects addCurves
   Rhino.EnableRedraw vbFalse
   For i = 0 To UBound(allCurves)
    addCurves(i) = CloseOpenCurve(allCurves(i), blnLine, blnJoin)
   Next
   Rhino.EnableRedraw vbTrue
  Case "P", "T"
   blnLine = Not blnLine
   Rhino.DeleteObjects addCurves
   Rhino.EnableRedraw vbFalse
   For i = 0 To UBound(allCurves)
    addCurves(i) = CloseOpenCurve(allCurves(i), blnLine, blnJoin)
   Next
   Rhino.EnableRedraw vbTrue
  Case "A"
   Exit Do
  Case "Q"
   Rhino.DeleteObjects addCurves : Exit Sub
  Case Else
   Rhino.Command strResult
  End Select
 Loop
 Rhino.SaveSettings Rhino.InstallFolder & "Gelfling.ini", "CloseOpenCurves", "Join", CStr(blnJoin)
 Rhino.SaveSettings Rhino.InstallFolder & "Gelfling.ini", "CloseOpenCurves", "Line", CStr(blnLine)
 If blnJoin Then Rhino.DeleteObjects allCurves
 Rhino.Print "Curves closed"
End Sub
CloseOpenCurves

Function CloseOpenCurve(objID, blnLine, blnJoin)
 CloseOpenCurve = "Nothing"
 Dim arrPt(3), arrPoints
 Dim addCurve, delCurve, i
 Dim crvName, crvLayer, crvCSource, crvColour, crvGroups

 If objID <> "Nothing" Then
  arrPoints = Rhino.CurvePoints(objID)
  If blnLine Then
   arrPt(0) = arrPoints(UBound(arrPoints))
   arrPt(1) = arrPoints(UBound(arrPoints))
   arrPt(2) = arrPoints(0)
   arrPt(3) = arrPoints(0)
  Else
   arrPt(0) = arrPoints(UBound(arrPoints))
   arrPt(1) = arrPoints(UBound(arrPoints)-1)
   arrPt(2) = arrPoints(1)
   arrPt(3) = arrPoints(0)
   For i=0 To 2
    arrPt(1)(i) = arrPt(0)(i) - (arrPt(1)(i)-arrPt(0)(i))
    arrPt(2)(i) = arrPt(3)(i) - (arrPt(2)(i)-arrPt(3)(i))
   Next
  End If

  crvName = Rhino.ObjectName(objID)
  crvLayer = Rhino.ObjectLayer(objID)
  crvCSource = Rhino.ObjectColorSource(objID)
  crvColour = Rhino.ObjectColor(objID)
  crvGroups = Rhino.ObjectGroups(objID)
  If blnLine Then
   addCurve = Rhino.AddPolyLine(arrPt)
  Else
   addCurve = Rhino.AddCurve(arrPt, 3)
  End If
  
  If blnJoin Then
   delCurve = addCurve
   addCurve = Rhino.JoinCurves(Array(addCurve, objID), vbFalse)(0)
   If Not IsNull(crvName) Then Rhino.ObjectName addCurve, crvName
   Rhino.DeleteObject delCurve
  Else
   If Not IsNull(crvName) Then Rhino.ObjectName addCurve, "Closing curve for " & crvName
  End If

  If Not IsNull(crvLayer) Then Rhino.ObjectLayer addCurve, crvLayer
  If Not IsNull(crvCSource) Then Rhino.ObjectColorSource addCurve, crvCSource
  If crvCSource = 1 And Not IsNull(crvColour) Then Rhino.ObjectColor addCurve, crvColour
  If Not IsNull(crvGroups) Then
   For i=0 To UBound(crvGroups)
    Rhino.AddObjectToGroup addCurve, crvGroups(i)
   Next
  End If
  CloseOpenCurve = addCurve
 End If
End Function

Ekleyen: Mad_Max