This script does not work inflate polisurfaces

Can somebody help me,

It was great to create these shapes:

Option Explicit
'Script written and copyrighted by Gelfling '04 aka David Rutten
'Last script revision on 25 april 2004

Sub Balloon()
	Dim idBalloon, idHairs, idInfBalloon
	Dim arrStart, dblRadius
	Dim strResult, arrOptions(6)
	Dim selWall, defWalls
	Dim uvDensity
	Dim stepSize
	Dim i, CP, radAuto

	selWall = Rhino.GetObject("Seleccione una superficie (poli) cerrada...", 8 + 16, vbTrue, vbTrue)
	If IsNull(selWall) Then Exit Sub
	If IsNull(Rhino.SurfaceVolume(selWall)) Then Exit Sub
	arrStart = Array(1E100, 1E100, 1E100)
	Do Until Rhino.IsPointInSurface(selWall, arrStart)
		arrStart = Rhino.GetPoint("Elija un punto dentro del volumen para comenzar el crecimiento...")
		If IsNull(arrStart) Then Exit Sub

	defWalls = ExtractWalls(selWall)
	uvDensity = Rhino.GetSettings(Rhino.InstallFolder & "Gelfling.ini", "Balloon", "uvDensity")
	If IsNull(uvDensity) Then uvDensity = 20 Else uvDensity = CInt(uvDensity)
	dblRadius = Rhino.GetSettings(Rhino.InstallFolder & "Gelfling.ini", "Balloon", "Radius")
	If IsNull(dblRadius) Then dblRadius = 1 Else dblRadius = CDbl(dblRadius)
	stepSize = Rhino.GetSettings(Rhino.InstallFolder & "Gelfling.ini", "Balloon", "stepSize")
	If IsNull(stepSize) Then stepSize = 1 Else stepSize = CDbl(stepSize)
	idBalloon = "Nothing"
	idHairs = Array("Nothing")

		Rhino.EnableRedraw vbFalse
		Rhino.Prompt "Generating preview..."
		Rhino.DeleteObject idBalloon
		Rhino.DeleteObjects idHairs
		idBalloon = AddBalloon(arrStart, dblRadius, uvDensity)
		idHairs = AddGrowLines(arrStart, dblRadius, stepSize)
		Rhino.SelectObjects idHairs
		Rhino.EnableRedraw vbTrue

		arrOptions(0) = "Insertion_Point"
		arrOptions(1) = "Radius"
		arrOptions(2) = "AutoRadius"
		arrOptions(3) = "Density_" & uvDensity
		arrOptions(4) = "Stepsize"
		arrOptions(5) = "Infl8"
		arrOptions(6) = "Quit"
		strResult = Rhino.GetString("Inflación sólida...", "Infl8", arrOptions)
		If IsNull(strResult) Then strResult = "Quit"
		If IsNumeric(strResult) Then
			strResult = Abs(CDbl(strResult))
			If strResult < Rhino.UnitAbsoluteTolerance Then strResult = Rhino.UnitAbsoluteTolerance
			stepSize = strResult
			strResult = "xxx"
		End If

		Select Case UCase(Left(strResult, 3))
			Case "INS"
				strResult = Rhino.GetPoint("Elija un nuevo punto para comenzar el crecimiento (debe estar encerrado el volumen)", arrStart)
				If Not IsNull(strResult) Then arrStart = strResult
			Case "RAD"
				strResult = Rhino.GetReal("Especifique un nuevo radio de globo inicial...", dblRadius, Rhino.UnitAbsoluteTolerance)
				If Not IsNull(strResult) Then dblRadius = strResult
			Case "AUT"
				radAuto = 1E12
				For i = 0 To UBound(defWalls)
					CP = Rhino.EvaluateSurface(defWalls(i), Rhino.SurfaceClosestPoint(defWalls(i), arrStart))
					If Rhino.Distance(arrStart, CP) < radAuto Then radAuto = Rhino.Distance(arrStart, CP)
				If radAuto = 1E12 Then
					msgBox "An error occured..." & vbNewLine & _
						"unable to determine an optimal radius.", vbOkOnly Or vbError, "Dang!"
					dblRadius = radAuto * 0.95
				End If
			Case "DEN"
				strResult = Rhino.GetInteger("Especifique una nueva densidad de globo...", uvDensity, 10, 1000)
				If Not IsNull(strResult) Then uvDensity = strResult
			Case "STE"
				strResult = Rhino.GetReal("Especifique un nuevo tamaño de paso de inflado...", stepSize, Rhino.UnitAbsoluteTolerance)
				If Not IsNull(strResult) Then stepSize = strResult
			Case "INF"
				Rhino.EnableRedraw vbFalse
				Rhino.DeleteObjects idHairs
				Rhino.EnableRedraw vbTrue
				Exit Do
			Case "QUI"
				Rhino.EnableRedraw vbFalse
				ShowObjects defWalls
				Rhino.DeleteObjects defWalls
				Rhino.DeleteObjects idBalloon
				Rhino.DeleteObjects idHairs
				Rhino.EnableRedraw vbTrue
				Exit Sub
		End Select
	Rhino.SaveSettings Rhino.InstallFolder & "Gelfling.ini", "Balloon", "uvDensity", CStr(uvDensity)
	Rhino.SaveSettings Rhino.InstallFolder & "Gelfling.ini", "Balloon", "Radius", CStr(dblRadius)
	Rhino.SaveSettings Rhino.InstallFolder & "Gelfling.ini", "Balloon", "stepSize", CStr(stepSize)

	idInfBalloon = InflateSurface(idBalloon, stepSize, defWalls, uvDensity)

	Rhino.EnableRedraw vbFalse
	ShowObjects defWalls
	Rhino.DeleteObjects defWalls
	Rhino.DeleteObject idBalloon
	Rhino.EnableRedraw vbTrue
	Exit Sub

	Rhino.Print "Balloon fully inflated..."
End Sub

Function InflateSurface(idSurface, stepSize, arrWalls, GridSize)
	InflateSurface = Null
	Dim arrPoints, i, j
	Dim fixState()
	Dim idCopy
	Dim uvCP, vecN, Ray
	Dim arrX, blnComplete

	idCopy = Rhino.CopyObject(idSurface)
	arrPoints = Rhino.SurfacePoints(idCopy)
	If IsNull(arrPoints) Then Exit Function
	ReDim fixState(UBound(arrPoints))
	For i = 0 To UBound(fixState)
		fixState(i) = vbFalse

	Rhino.EnableRedraw vbFalse
		arrPoints = Rhino.SurfacePoints(idCopy)

		For i = 0 To UBound(arrPoints)
			If Not fixState(i) Then
				If i / GridSize = i \ GridSize And i <> 0 Then
					fixState(i) = fixState(0)
					arrPoints(i) = arrPoints(0)
				ElseIf (i + 1) / GridSize = (i + 1) \ GridSize And i + 1 <> GridSize Then
					fixState(i) = fixState(GridSize - 1)
					arrPoints(i) = arrPoints(GridSize - 1)
					uvCP = Rhino.SurfaceClosestPoint(idCopy, arrPoints(i))
					vecN = Rhino.SurfaceNormal(idCopy, uvCP)
					If IsNull(vecN) Then vecN = Array(Array(0, 0, 0), Array(0, 0, 0))
					If Rhino.Distance(array(vecN(0), vecN(1))) <> 0 Then
						For j = 0 To 2
							vecN(1)(j) = arrPoints(i)(j) + (vecN(1)(j) - vecN(0)(j))
							vecN(0)(j) = arrPoints(i)(j)
						vecN = ResizeVector(vecN, stepSize)
						Ray = Rhino.AddLine(vecN(0), vecN(1))
						If Not IsNull(Ray) Then
							For j = 0 To UBound(arrWalls)
								arrX = Rhino.CurveSurfaceIntersection(Ray, arrWalls(j))
								If IsArray(arrX) Then
									'If Rhino.IsPointOnSurface(arrWalls(j), arrX(0,1)) Then
									fixState(i) = vbTrue
									If Rhino.Distance(vecN(0), vecN(1)) > Rhino.Distance(vecN(0), arrX(0, 1)) Then
										vecN(1) = arrX(0, 1)
									End If
									'End If
								End If
							Rhino.DeleteObject Ray
						End If
						arrPoints(i) = vecN(1)
						fixState(i) = vbFalse
					End If
				End If
			End If

		Rhino.DeleteObject idCopy
		idCopy = Rhino.AddNurbsSurface(Rhino.SurfacePointCount(idSurface), _
			arrPoints, _
			Rhino.SurfaceKnots(idSurface)(0), _
			Rhino.SurfaceKnots(idSurface)(1), _
			Rhino.SurfaceDegree(idSurface), _
		Rhino.EnableRedraw vbTrue
		Rhino.EnableRedraw vbFalse
		blnComplete = vbTrue
		For i = 0 To UBound(fixState)
			If Not fixState(i) Then blnComplete = vbFalse
		If blnComplete Then Exit Do
	Rhino.EnableRedraw vbTrue
	InflateSurface = idCopy
End Function

Function AddBalloon(arrStart, dblRadius, uvDensity)
	AddBalloon = Null
	Dim idSphere

	idSphere = Rhino.AddSphere(arrStart, dblRadius)
	If IsNull(idSphere) Then Exit Function
	Rhino.SelectObject idSphere
	Rhino.Command "-_Rebuild _UPointCount=" & uvDensity & _
		" _VPointCount=" & uvDensity & _
		" _UDegree=3 _VDegree=3 _DeleteInput=Yes _CurrentLayer=Yes _ReTrim=No _Enter", vbFalse
	Rhino.Prompt "Generating preview..."
	If Not Rhino.IsObject(idSphere) Then Exit Function
	AddBalloon = idSphere
End Function

Function AddGrowLines(O, R, S)
	AddGrowLines = Null
	Dim Hair(5)
	Hair(0) = Rhino.AddLine(Array(O(0) + R, O(1), O(2)), Array(O(0) + R + S, O(1), O(2)))
	Hair(1) = Rhino.AddLine(Array(O(0) - R, O(1), O(2)), Array(O(0) - R - S, O(1), O(2)))
	Hair(2) = Rhino.AddLine(Array(O(0), O(1) + R, O(2)), Array(O(0), O(1) + R + S, O(2)))
	Hair(3) = Rhino.AddLine(Array(O(0), O(1) - R, O(2)), Array(O(0), O(1) - R - S, O(2)))
	Hair(4) = Rhino.AddLine(Array(O(0), O(1), O(2) + R), Array(O(0), O(1), O(2) + R + S))
	Hair(5) = Rhino.AddLine(Array(O(0), O(1), O(2) - R), Array(O(0), O(1), O(2) - R - S))
	AddGrowLines = Hair
End Function

Function ExtractWalls(idSurface)
	If Rhino.IsSurface(idSurface) Then
		ExtractWalls = Array(Rhino.CopyObject(idSurface))
		Rhino.HideObjects ExtractWalls
		Exit Function
		ExtractWalls = Rhino.ExplodePolySurfaces(idSurface, vbFalse)
		Rhino.HideObjects ExtractWalls
		Exit Function
	End If
	ExtractWalls = Null
End Function

Function ResizeVector(vecIn, newLength)
	ResizeVector = vecIn
	Dim vecOut(1)

	vecOut(0) = Array(vecIn(0)(0), vecIn(0)(1), vecIn(0)(2))
	vecOut(1) = Array((vecIn(0)(0) + (vecIn(1)(0) - vecIn(0)(0)) * newLength), _
		(vecIn(0)(1) + (vecIn(1)(1) - vecIn(0)(1)) * newLength), _
		(vecIn(0)(2) + (vecIn(1)(2) - vecIn(0)(2)) * newLength))
	ResizeVector = vecOut
End Function

I am currently performing this but I want to do the inflated shape.

@DavidRutten can you help?

1 Like

Por favor ayuda It’s a great script
@pascal @clement @Helvetosaur @DavidRutten
Long ago i use it now it does not work

I think the error is only on line 152, an array is missing

Hi @vikthor, this script is from ancient Rhino 3 times and i do not even speak the language the prompts are written in :wink:

I think there are a few minor things wrong, eg. in line 94:

ShowObjects defWalls

should be:

Rhino.ShowObjects defWalls

But the major problem is that after Rhino 3, the Rhino.SurfaceNormal method in line 150 changed. In ancient times it returned 2 points as an array, the first one sitting on the surface, and the other was a normal added to this point with a length of 1. After Rhino 3 this method changed and now returns a normalized vector at the world origin.

To get something like the old behaviour i’ve changed something near line 150 and added the missing point on the surface (ptx) and added the normal Rhino 5 returns to the point on the surface, so the variable vecN now contains the normal like in Rhino 3. Note that i have added this line first, in the start section of the InflateSurface function:

Dim ptx

then later made this change for the surface normal:

uvCP = Rhino.SurfaceClosestPoint(idCopy, arrPoints(i))
vecN = Rhino.SurfaceNormal(idCopy, uvCP)
ptx = Rhino.EvaluateSurface(idCopy, uvCP)
vecN = Array(ptx, Rhino.VectorAdd(ptx, vecN))

the error you get in line 152 comes from this line for sure:

If Rhino.Distance(array(vecN(0), vecN(1))) <> 0 Then

this cannot work, since Rhino.Distance is expecting 2 points not an array. I changed it to:

If Rhino.Distance(vecN(0), vecN(1)) <> 0 Then

After some testing with a cube, the script seems to finish but takes a while. I am not sure if all these options still work, just tested with some simple boxes…

I would recommend to run it in Wireframe display mode to prevent the render mesh creation while it runs. I`ve added a few comments where i did the changes:

Inflate.rvb (9.1 KB)

@DavidRutten, i hope this is ok. Quite amazing what you did 14 years ago ! :nerd:



Thanks, looking at the script I felt pretty lost myself. I’m having a hard time getting back into VB.NET these days, let alone RhinoScript.

1 Like

Many thanks. @clement
I apologize for the inconvenience,
If the script was something old
It works perfect :slight_smile:

I think I have air leaks on the polysurface