Macro para dibujar polilíneas (rectángulos) en autocad desde excel

Описание к видео Macro para dibujar polilíneas (rectángulos) en autocad desde excel

Herramienta útil para dibujar polilíneas en autocad a partir de una tabla de datos en excel, en este caso dibuja rectángulos con una polilínea.

Macro:
Sub dibujar_rectangul()

Dim ORIGEN_X, FIN_X, ORIGEN_Y, ALTURA_RENGLON As Double
Dim a As Integer
Set DOC = AutoCAD.Application.ActiveDocument
'DOC.SendCommand "e all "
DOC.PurgeAll

Sheets("hoja1").Activate


a = Cells(Rows.Count, 1).End(xlUp).Row

ALTURA_RENGLON = ActiveSheet.Cells(2, 5)
ORIGEN_Y = ActiveSheet.Cells(1, 5)

For i = 2 To a Step 1

ORIGEN_X = ActiveSheet.Cells(i, 1)
FIN_X = ActiveSheet.Cells(i, 2)

dibujar_rectangulo ALTURA_RENGLON, ORIGEN_X, FIN_X, ORIGEN_Y

Next i

DOC.SendCommand ("Z E ")
MsgBox ("terminó")
End Sub

Function dibujar_rectangulo(ALTURA_RENGLON, ORIGEN_X, FIN_X, ORIGEN_Y)
Set DOC = AutoCAD.Application.ActiveDocument
Dim POL As AcadPolyline
Dim pnt(14) As Double
pnt(0) = ORIGEN_X: pnt(1) = ORIGEN_Y: pnt(2) = 0
pnt(3) = FIN_X: pnt(4) = pnt(1): pnt(5) = pnt(2)
pnt(6) = pnt(3): pnt(7) = ORIGEN_Y + ALTURA_RENGLON: pnt(8) = pnt(2)
pnt(9) = pnt(0): pnt(10) = pnt(7): pnt(11) = pnt(2)
pnt(12) = pnt(0): pnt(13) = pnt(1): pnt(14) = pnt(2)
Set POL = DOC.ModelSpace.AddPolyline(pnt)
End Function

Комментарии

Информация по комментариям в разработке