@vikthor wrote:
Can somebody help me,
It was great to create these shapes:![]()
Option Explicit
'Script written and copyrighted by Gelfling '04 aka David Rutten
'http://www.nurbs.tk info@nurbs.tk
'Last script revision on 25 april 2004Sub 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 Loop 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") Do 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) Next If radAuto = 1E12 Then msgBox "An error occured..." & vbNewLine & _ "unable to determine an optimal radius.", vbOkOnly Or vbError, "Dang!" Else 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 Loop 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 Balloon 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 Next Rhino.EnableRedraw vbFalse Do 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) Else 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) Next 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 Next Rhino.DeleteObject Ray End If arrPoints(i) = vecN(1) Else fixState(i) = vbFalse End If End If End If Next Rhino.DeleteObject idCopy idCopy = Rhino.AddNurbsSurface(Rhino.SurfacePointCount(idSurface), _ arrPoints, _ Rhino.SurfaceKnots(idSurface)(0), _ Rhino.SurfaceKnots(idSurface)(1), _ Rhino.SurfaceDegree(idSurface), _ Rhino.SurfaceWeights(idSurface)) Rhino.EnableRedraw vbTrue Rhino.EnableRedraw vbFalse blnComplete = vbTrue For i = 0 To UBound(fixState) If Not fixState(i) Then blnComplete = vbFalse Next If blnComplete Then Exit Do Loop 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.UnselectAllObjects 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 Else 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
Posts: 2
Participants: 1