Hi,
I have this:
I will show you a VBA code in AutoCAD that creates a new rectangle when it detects an intersection between two polylines. The dimensions of this new rectangle are based on the maximum dimensions of the previous rectangles. The problem is that the code only works if the first polyline intersects with the others, but I want it to continue checking with the second and subsequent polylines without including the previous one, since that has already been done. Then it should proceed with the third polyline and the remaining ones, excluding the previous ones, because that has also been completed, and so on. I would greatly appreciate any kind of assistance. Thank you."
Private Sub CommandButton1_Click()
Dim Sset As AcadSelectionSet
Dim filterType(0) As Integer, i As Integer, j As Integer
Dim filterData(0) As Variant
Dim PL() As AcadLWPolyline, pol As AcadLWPolyline
Dim p(0 To 5) As Double, p1(0 To 5) As Double, p2(0 To 9) As Double
Dim D(2) As Double
Dim l As AcadLine
Dim pt(0 To 2) As Double, pt1(0 To 2) As Double
'seleccionar polilíneas de la capa "column"
filterType(0) = 8: filterData(0) = "COLUMN"
Set Sset = ThisDrawing.SelectionSets.Add("2K")
Sset.Select acSelectionSetAll, , , filterType, filterData
ReDim PL(Sset.Count - 1)
'asignar variable pl para manipularlas
For i = 0 To Sset.Count - 1
Set PL(i) = Sset.Item(i)
Next i
'Empezar iteración de todas las polilíneas con respecto a la polínea inicial
For i = 1 To Sset.Count - 1
'verificar si los rectangulos se intersectan
If UBound(PL(0).IntersectWith(PL(i), acExtendNone)) <> -1 Then
'Conseguir las coordenadas del segundo rectangulo
For j = 0 To 5
p(j) = PL(1).Coordinates(j)
Next j
'Conseguir las dimensión más larga del segundo rectangulo
D(0) = Abs(p(0) - p(2)): D(1) = Abs(p(3) - p(5))
If D(0) > D(1) Then
D(2) = D(0)
Else
D(2) = D(1)
End If
'Conseguir las coordenadas del primer rectangulo
For j = 0 To 5
p(j) = PL(0).Coordinates(j)
Next j
'Conseguir las dimensión más larga del primer rectangulo
D(0) = Abs(p(0) - p(2)): D(1) = Abs(p(3) - p(5))
'condicional para crear nuevo rectangulo
If D(0) > D(1) Then
'asignar coordenadas para nuevo rectangulo
For j = 0 To 3
p2(j) = p(j)
Next j
pt(0) = p2(0): pt(1) = p2(1)
pt1(0) = p2(2): pt1(1) = p2(3)
Set l = ThisDrawing.ModelSpace.AddLine(pt, pt1)
p2(4) = p2(2) - D(2) * Sin(l.Angle): p2(5) = p2(3) + D(2) * Cos(l.Angle)
p2(6) = p2(0) - D(2) * Sin(l.Angle): p2(7) = p2(1) + D(2) * Cos(l.Angle)
p2(8) = p2(0): p2(9) = p2(1)
Set pol = ThisDrawing.ModelSpace.AddLightWeightPolyline(p2)
Else
'Esto sucedería si no se cumple la primera condición
For j = 2 To 5
p2(j) = p(j)
Next j
'asignar coordenadas para nuevo rectangulo
pt(0) = p2(2): pt(1) = p2(3)
pt1(0) = p2(4): pt1(1) = p2(5)
Set l = ThisDrawing.ModelSpace.AddLine(pt, pt1)
p2(6) = p2(4) - D(2) * Sin(l.Angle): p2(7) = p2(5) + D(2) * Cos(l.Angle)
p2(8) = p2(2) - D(2) * Sin(l.Angle): p2(9) = p2(3) + D(2) * Cos(l.Angle)
p2(0) = p2(8): p2(1) = p2(9)
Set pol = ThisDrawing.ModelSpace.AddLightWeightPolyline(p2)
End If
l.Delete
End If
Next i
Sset.Delete
ThisDrawing.Regen acActiveViewport
End Sub