Option Explicit
Sub Poly2CrvMid ()
Dim arrCrvs,strCrv, arrPoints,arrPoint
Dim K,i,arrNPt,hh,kk
arrCrvs = Rhino.GetObjects("Select curves", 4)
If IsNull(arrCrvs) Then Exit Sub
ReDim arrCC(UBound(arrCrvs))
hh=0
For Each strCrv In arrCrvs
If Rhino.IsPolyline(strCrv) Then
arrPoints = Rhino.PolylineVertices(strCrv)
If IsArray(arrPoints) Then
k=UBound(arrPoints)
kk=(k+1)*2-2
ReDim arrNPt(kk)
Dim nn : nn=0
For i=1 To kk Step 2
arrNPt(i) = Array((arrPoints(nn)(0)+arrPoints(nn+1)(0))/2, (arrPoints(nn)(1)+arrPoints(nn+1)(1))/2, (arrPoints(nn)(2)+arrPoints(nn+1)(2))/2 )
nn=nn+1
Next
nn=0
For i=0 To kk Step 2
arrNPt(i) = arrPoints(nn)
nn=nn+1
Next
arrCC(hh) = Rhino.AddCurve (arrNPt ,3)
hh=hh+1
End If
End If
Next
Rhino.SelectObjects arrCC
End Sub
Poly2CrvMid |