Hello everyone,
I have a VBA code in AutoCAD that is used to create brick walls in a drawing. The code works correctly, but as I repeatedly run the form to create more walls, I notice that the process becomes slower over time. This is because the current code does not effectively handle the accumulation of elements in the "Brick" layer and the selection of elements in each execution.
I will share the complete code with all the details because I am seeking recommendations and solutions to optimize the performance of my code. Any advice will be welcome to improve the speed of wall creation and avoid performance issues as more walls are created in the drawing.
Thank you in advance for your assistance!
Public n0 As Double, n1 As Double, n2 As Double, n3 As Double, angli As Double
Public sx As Double, sz As Double, mortero As Double, pz As Double, lm As Double
Public bl As Double, hl As Double, dc As Double
Public k As Integer, k1 As Integer
Public pt As Variant, p As Variant
Private Sub CommandButton1_Click()
Dim pt1 As Variant, mi(0) As Variant
Dim L As AcadLine
Dim c1 As Integer, cod(0) As Integer, I As Integer
Dim muro As Acad3DSolid, la() As Acad3DSolid
Dim lo As AcadLayer
Dim Sset As AcadSelectionSet
Me.Hide
'crear una capa llamada "ladrillos"
Set lo = ThisDrawing.Layers.Add("Ladrillo")
ThisDrawing.ActiveLayer = lo
lo.color = acRed
pt = ThisDrawing.Utility.GetPoint(, "Haga clic en donde el empezará el muro")
pt1 = ThisDrawing.Utility.GetPoint(, "Haga clic en donde el terminará el muro")
Set L = ThisDrawing.ModelSpace.AddLine(pt, pt1)
n0 = 0.13 / 2: n1 = 0.24 / 2: n2 = 0.09: n3 = 1: mortero = 0.015
angli = L.Angle: lm = L.Length
sx = 2 * n1 + mortero
sz = n2 + mortero
'crear el muro sin ladrillos
pt1(0) = pt(0) + lm / 2: pt1(1) = pt(1) + n0: pt1(2) = pt(2) + n3 / 2
Set muro = ThisDrawing.ModelSpace.AddBox(pt1, lm, 2 * n0, n3)
muro.Rotate pt, angli
k1 = 0
'crear crear_hileras vertidcles
Do While n2 + sz * k1 <= n3
k = 0
'crear crear_hileras horizontales
If k1 Mod 2 = 0 Then
c1 = 2: crear_hileras c1
Else
c1 = 3: crear_hileras c1
'insertar primer ladrillo horizontal de filas pares
dc = n1 / 2
pz = pt(2) + n2 / 2 + sz * k1
bl = n1
hl = n2
crear_ladrillo dc, pz, bl, hl
End If
k1 = k1 + 1
Loop
L.Delete
cod(0) = 8: mi(0) = "Ladrillo"
Set Sset = ThisDrawing.SelectionSets.Add("S")
Sset.Select acSelectionSetAll, , , cod, mi
ReDim la(Sset.Count - 1)
For I = 0 To Sset.Count - 1
Set la(I) = Sset.Item(I)
Sset.Item(I).Copy
On Error GoTo salir
muro.Boolean acSubtraction, la(I)
Next I
ThisDrawing.Application.Update
Me.show
salir:
Sset.Delete
Me.show
End Sub
Sub crear_hileras(c1 As Integer)
Do While c1 * n1 + sx * k <= lm
dc = IIf(c1 = 2, n1 + sx * k, sx * (k + 1))
pz = pt(2) + n2 / 2 + sz * k1
bl = 2 * n1
hl = n2
crear_ladrillo dc, pz, bl, hl
'crear última hilera
If pz + 1.5 * n2 + mortero >= n3 Then
dc = IIf(c1 = 2, sx * (k + 1), n1 + sx * k)
hl = n3 - 0.5 * n2 - p(2) - mortero
pz = pz + 0.5 * n2 + mortero + hl / 2
crear_ladrillo dc, pz, bl, hl
End If
k = k + 1
Loop
If pz + 1.5 * n2 + mortero >= n3 And k Mod 2 <> 0 Then
dc = n1 / 2
bl = n1
crear_ladrillo dc, pz, bl, hl
End If
End Sub
Sub crear_ladrillo(dc As Double, pz As Double, bl As Double, hl As Double)
Dim ladrillo As Acad3DSolid
'crear ladrillo
p = calcular_centro(dc, pz)
Set ladrillo = ThisDrawing.ModelSpace.AddBox(p, bl, 2 * n0, hl)
ladrillo.Rotate p, angli
'ajustar último ladrillo horizontal
If dc + 3 * n1 + mortero >= lm Then
dc = 0.5 * (lm + dc + n1 + mortero)
p = calcular_centro(dc, pz)
bl = 2 * (lm - dc)
On Error GoTo error
Set ladrillo = ThisDrawing.ModelSpace.AddBox(p, bl, 2 * n0, hl)
ladrillo.Rotate p, angli
End If
error:
End Sub
Function calcular_centro(dc As Double, pz As Double) As Variant
Dim ang As Double, hip As Double
ang = Atn(n0 / dc) + angli
hip = Sqr(n0 ^ 2 + dc ^ 2)
p = ThisDrawing.Utility.PolarPoint(pt, ang, hip)
p(2) = pz
calcular_centro = p
End Function
jefferson
