Const Const Const Const Const Const
M = 4 N = 4 FLOORS = 10 TURNS = 10 EXPAND = 0.02 THRESHOLD = 1
'number 'number 'number 'number 'growth
of of of of of
vertices curves floors adjusting loops fixed node values
create polygon meshes
Dim COLUMNS As AcadLayer Sub main() Dim Dim Dim Dim Dim Dim Dim Dim i As Integer, c As Integer, j As Integer, f As Integer npts(N * M * 3 - 1) As Double fixed(1 To FLOORS, N * M) As Boolean p1 As Variant, p2 As Variant dist As Double roof(1 To FLOORS) As AcadPolygonMesh color As New AcadAcCmColor column As AcadLine
'jiggle' node points in mesh
ThisDrawing.SendCommand "erase" & vbCr & "all" & vbCr & vbCr Randomize Set SUPPORTS = ThisDrawing.Layers.Add("COLUMNS") For f = 1 To FLOORS j = 0 For c = 1 To N For i = 0 To (M * 3 - 1) Step 3 npts(j) = c npts(j + 1) = i npts(j + 2) = f j = j + 3 Next i Next c Set roof(f) = ThisDrawing.ModelSpace.Add3DMesh(N, M, npts) roof(f).color = acBlue ZoomExtents Next f For t = 0 To TURNS If (t > 0) Then feedback roof, fixed For f = 1 To FLOORS - 1 For i = 0 To UBound(roof(1).Coordinates) Step 3 p1 = roof(f + 1).Coordinate(i / 3) p2 = roof(f).Coordinate(i / 3) If t = 0 Then p1(0) = ran(p1(0) - 0.5, p1(0) + 0.5) p1(1) = ran(p1(1) - 0.5, p1(1) + 0.5) p1(2) = ran(p1(2) - 0.5, p1(2) + 0.5) roof(f + 1).Coordinate(i / 3) = p1 End If dist = Sqr((p1(0) - p2(0)) ^ 2 + (p1(1) - p2(1)) ^ 2 + (p1(2) - p2(2)) ^ 2) If (dist < THRESHOLD) Then Set column = ThisDrawing.ModelSpace.AddLine(p2, p1) connector column fixed(f + 1, i / 3) = True End If Next i Next f ZoomExtents Next t ThisDrawing.Regen acAllViewports ZoomExtents End Sub Sub connector(pathline As AcadLine) Dim Dim Dim Dim Dim profile(0) As AcadEntity vec(2) As Double reg As Variant support As Acad3DSolid color As New AcadAcCmColor
recalculate mesh
calculate distance between corresponding node in mesh above
recalculate mesh
if distance is less than 3
if distance is greater than 3
draw line between the two points
vec(0) = pathline.EndPoint(0) - pathline.StartPoint(0) vec(1) = pathline.EndPoint(1) - pathline.StartPoint(1) vec(2) = pathline.EndPoint(2) - pathline.StartPoint(2) Set profile(0) = ThisDrawing.ModelSpace.AddCircle(pathline.StartPoint, pathline.Length / 20) profile(0).Normal = vec reg = ThisDrawing.ModelSpace.AddRegion(profile) Set support = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(reg(0), pathline) support.color = acRed support.Layer = "COLUMNS" profile(0).Delete pathline.Delete reg(0).Delete End Sub Sub wipe_layer(token As Integer) Dim dt(0) As Integer Dim dv(0) As Variant Dim ss As AcadSelectionSet dt(0) = 8 dv(0) = "COLUMNS" Set ss = ThisDrawing.SelectionSets.Add("destroy") ss.Select acSelectionSetAll, , , dt, dv If (ss.Count > 0) Then ss.Erase End If ss.Delete End Sub Function ran(low As Double, high As Double) As Double ran = (high - low) * Rnd + low End Function Sub feedback(sheets() As AcadPolygonMesh, hold() As Boolean) Dim change As Double For f = 1 To FLOORS - 1 For i = 0 To UBound(sheets(1).Coordinates) Step 3 If (hold(f + 1, i / 3) = True) Then change = EXPAND Else change = EXPAND / -2 End If p1 = sheets(f + 1).Coordinate(i / 3) p1(2) = p1(2) + EXPAND sheets(f + 1).Coordinate(i / 3) = p1 hold(f + 1, i / 3) = False Next i Next f End Sub
delete 'columns' extrude circle along line to create column
repeat as required final loop
delete 'columns'
repeat as required
'hold' node point at top of 'column'
increase height [z value] of node at bottom of 'column'
decrease height [z value] of node point
end