Este emprendimiento surgió como una necesidad de urgencia por buscar una respuesta a dos preguntas básicas, cortas pero pero difíciles de responder.
Cuando se termina el Proyecto?
Cual es la relación entre el avance físico y el tiempo transcurrido?
Y la pregunta que me hice yo a partir de las dos anteriores! Que tan seguro estoy de lo que voy a contestar?
Mostrando entradas con la etiqueta Programación Visual Basic Excel | AutoCAD. Mostrar todas las entradas
Mostrando entradas con la etiqueta Programación Visual Basic Excel | AutoCAD. Mostrar todas las entradas
La estructura de la información para obras edilicias
Desde hace un tiempo
percibí el enorme conflicto que existe en este rubro con el manejo
de la información como herramienta vital del proceso de construir.
Lo anterior resumido en un lenguaje mundano significa que al no haber un consenso entre las partes interesadas en las maneras, métodos y formatos de organizar y compartir la información nos lleva indefectiblemente al desgaste de invertir tiempo en interpretar la personalización de formatos en los planos de proyectos, sobre todo en la manera de dibujar y presentarlos, a tener que interpretar diversas planillas y controles que intentan reflejar lo mismo pero de formas diametralmente opuestas.
Hasta acá el desgaste solo se traduce en tiempo y claro que atentan contra la capacidad de quien interpreta la información recibida entendiendo que este es idóneo en el tema y tiene que deducir todo el razonamiento que lo llevó a presentar el trabajo de tal o cual manera. Cuando a esto le sumamos un problema de dialogo en los equipos de trabajo surge el peligro más doloroso, el ejecutar o trabajar en base a información no vigente por el solo hecho de haber un conflicto de entre quienes producen la información y quienes las toman como referencia para tomar decisiones.
Con el tiempo, algunas mañas de acumular documentación como una anécdota de mi experiencia, surgió el dilema que había participado de varios proyectos con diferentes tipos de responsabilidades, de que todavía conservo toda la información o la mayor parte de ella y que una manera de evolucionar en cada objetivo nuevo era volver hacia la última experiencia y tomarla como punto de partida para acomodarla a la situación que se presente.
Entonces partí de la base de que quería organizar todos los proyectos en los que he trabajado y de
los que trabajaré, de forma que me permita acceder a la información
de una manera directa sin navegar por la computadora horas, y esto me llevo a razonar todos los hitos y procesos de la vida de un proyecto donde se genera o se registra un documento.
Aclarando que todos los proyectos que traje al caso son de construcción de obras edilicias surgió la siguiente estructura de información:
Estructura de las carpetas:
Macro para diseñar, computar y presupuestar obras de instalación eléctrica enlazando AutoCAD con Excel.
Si bien al momento de emprender esta macro ya existían otras que ofrecían estos beneficios, todas las opciones requerían de pagar una licencia y aprender una nueva metodología de trabajo con todo lo que esto implica en cuestión de tiempo y dedicación sin conocer con certeza si los alcances se ajustaban a los requerimientos. Fue aquí donde surgió esta idea ambiciosa de tomar los procesos artesanos que hasta el momento practicaba un grupo de ingenieros eléctricos, meterme en todos sus procesos del diseño, cómputos, certificación y conducción de las obras e intentar resumir algunos aspectos del trabajo diario.
Esta aplicación fue creada con el fin de ser usada en obras edilicias convencionales con estructura de concreto.
Sin mayores excusas paso a comentar de que se trata este conjuntos de macros que terminaron formando una aplicación integral:
El primer paso fue definir toda la simbología que según normas pre establecidas serían usadas para los proyectos.
Una vez definida se redibujaron teniendo en cuenta que sería necesario dibujar a escala real todo aquello que nos ayude a tener precisión en los proyectos.
A partir de esto una simple macro que ponga una planta arquitectónica en modo borrador entendiendo que un factor importante son los muros y las vigas, y por supuesto saber de qué se trata cada espacio.
Para agilizar el trabajo de proyecto se creó también un panel de botones en AutoCAD que al apretar cada símbolo nos pediría hacer click a donde insertarlo.
Auxiliado por la botonera se insertan todos los elementos eléctricos del proyecto según el mejor criterio de diseño.
Nos queda de la siguiente manera:
A partir de acá se unen los elementos con polilíneas realmente como serán los circuitos.
Con lo anterior realizado empezamos a analizar los circuitos, para esto nos auxiliamos de otra macro.
Se definió las posibles combinaciones de cables que podrían llevar cada tubería. Una regla mnemotécnica muy simple de aprender que en este momento no me voy a extender. Pero el caso es que al hacer click en cada botón y luego seleccionar una tubería asignará su diámetro y el tipo con la combinación de cables que contiene.
Ej:
a = 2x1,5 + T
a’=3x1,5 + T
b =2x2,5 + T
Etc.
Así pinchamos en la nomenclatura que queramos usar y a continuación seleccionamos el caño a la cual queremos asignarle esta nomenclatura, una vez seleccionado el caño insertamos el punto medio del dibujo del texto de la nomenclatura y finalmente con otro click asignamos su orientación para una fácil lectura.
Cada símbolo insertado deja asignada una capa predeterminada al caño. Es condición inalterable que cada caño este definido por una capa que indique su nomenclatura, como por ejemplo: una arco en la capa “A” indica que es una cañería que recorre por losa y es de la nomenclatura 2X1,5 + T.
Ej:
a = 2x1,5 + T
a’=3x1,5 + T
b =2x2,5 + T
Etc.
Así pinchamos en la nomenclatura que queramos usar y a continuación seleccionamos el caño a la cual queremos asignarle esta nomenclatura, una vez seleccionado el caño insertamos el punto medio del dibujo del texto de la nomenclatura y finalmente con otro click asignamos su orientación para una fácil lectura.
Cada símbolo insertado deja asignada una capa predeterminada al caño. Es condición inalterable que cada caño este definido por una capa que indique su nomenclatura, como por ejemplo: una arco en la capa “A” indica que es una cañería que recorre por losa y es de la nomenclatura 2X1,5 + T.
Ampliando el ejemplo nos queda de la siguiente manera el proyecto.
Quizás llame la atención de que en el siguiente plano hay cañería en azul y también en rojo, la razón de esta fue ya asignarle al programa que mientras coloque la nomenclatura, del color rojo a todos los caños que son RS16, azul a todos los RS19, verde a los RS22 y violeta a los RS38 (queda a criterio usar o no caños RS13 ya que por su debilidad y diferencia en costo con el RS16 por experiencia se eligió usar RS16) sin alejarme del asunto, el hecho de los distintos colores es que para el momento de la ejecución de la obra, basta con entregarle al operario el plano con los muros, vigas cotas y cañerías en distintos colores y una referencia que diga que color es cada caño, entonces ya no entregamos nomenclaturas y reducimos la posibilidad de error.
Un detalle muy importante es que hasta aquí solo tenemos la proyección horizontal del proyecto, pues nos falta todo lo vertical, para esto se indica en cada caja una bajada con el símbolo naranja que se ve a continuación, este símbolo indica una continuación de la tubería en dirección vertical con una distancia hacia el artefacto.
Nos pedirá un poquito de espera, que por cierto para matar la ansiedad y la incertidumbre se agregó la animación de que cada tubo que se lee va cambiando de color.
Este panel es casi lo mas importante del éxito del programa ya que con una revisión de lo ejecutado contra el cómputo se podrá ir ajustando los porcentajes de desperdicio y error para los planos futuros, este porcentaje puede ser muy variable según la calidad de la mano de obra.
Notaremos lo siguiente. Las líneas en muros se empezaran a poner de color naranja y las de losa de color verde, este no es mas que un control propio de errores, si de repente al finalizar el computo notamos que alguna línea mantiene el color original, esto quiere decir que algún error hay, el posible error es que la línea no tenga la nomenclatura asignada, recordemos que al asignar una nomenclatura esta asigna por defecto una capa y un color, y es esta capa y línea la que el programa lee.
Listo, al desaparecer la leyenda central de la pantalla. Se abrirá un Excel con nuestro cómputo métrico correspondiente a nuestra selección, en forma de cómputo detallado en tres etapas: La primera que será la etapa de losas, la segunda que será la etapa de paredes y la tercera que será la etapa de cableado.
Porteros Eléctricos, Tapas Rectangulares ciegas RED, Llave de 2 combinaciones, Llave de 2 combinaciones y un dimer, Llave de 2 dimers, Artefacto de dos tubos fluorescentes, Llave de 2 puntos, Llave de 2 tomacorriente, Llave de 3 combinaciones, Llave de 3 dimer, Artefacto de 3 tubos fluorescentes, Llave de 3 puntos, Tomacorriente trifásico, Artefacto de 4 fluorescentes, Artefacto de 8 fluorescentes, Artefacto de 8 fluorescentes y uno de emergencia, Tomacorriente de 20A, Artefacto aplique exterior, Farolas exteriores, Campanilla para timbre, Rosetas de madera chicas, Artefacto de centro de 2 velas, Artefacto de centro de 1 vela, Célula Fotoeléctrica, Llave de combinación, Llave de combinación y dimer, Llave de combinación y tomacorriente, Dicroicas, Llave de 2 puntos y combinación, Llave de dimer, Flotante para tanque de reserva de agua, Llave de punto, Llave de 2 puntos y dimer, Llave de punto y combinación, Llave de punto y dimer, Llave de punto y tomacorriente, Llave con pulsador de escalera, Tapas Rectangulares ciegas TE, Llave pulsador de timbre, Tomacorriente, Tapas Rectangulares ciegas TV, Ventilador de techo, Ventilador de techo con cuatro luminarias, Florones, Cajas Rectangulares, Caja octogonal chica, Rosetas para aplique, Caja cuadrada 10x10, Tapa ciega cuadrada 10x10, Caja cuadrada 15x15, Tapa ciega cuadrada 15x15, Caja cuadrada 20x20, Tapa ciega cuadrada 20x20, Tablero seccional, Cajas octogonales grandes, Artefacto de luz de emergencia, Medidores, Cajas de Medidores, Tornillos y tacos fisher, Cables, Caños y Conectores.
Si te interesa dale al boton G+, comenta, participa...
Y escribime para enviarte el ejemplo!
Panel de Control y Trazabilidad de las Compras y Suministros
En general,
por mucha programación que se pueda pronosticar en un proceso de producción, una pata
fundamental para el cumplimiento es el suministro de los insumos.
Siguiendo el concepto que indica el estándar de las normas ISO 9001, que detalla en resumen que si un proceso es crítico para la satisfacción del resultado, este proceso debe de ser controlado en toda su trazabilidad.
El primer paso para avanzar sobre lo anterior fue entender y visualizar el proceso en su totalidad y quedo de la siguiente manera y surgió el flujograma del Proceso.
Junto al flujograma surgieron establecer los siguientes objetivos:
- Establecer tiempo lógico de respuestas.
- Tiempo de proceso de la orden de compra = 1 días.
- Tiempo para la cotización = 2 días.
- Tiempo de aprobación de la orden de compra = 1 día.
- Tiempo de envío de la orden de compra al proveedor = 1 día.
- Tiempo de entrega del material = Depende la negociación.
- Pago al proveedor = Preestablecido con apr. de contabilidad.
- Para Compras de insumos nuevos incrementar la investigación de los proveedores = +3 días.
- Tiempo del proceso= 7 días + Tiempo de entrega del proveedor.
- Para compras frecuentes el tiempo del proceso será 5 días + Tiempo de entrega del proveedor.
La
aplicación consiste en determinar cada hito del proceso de las compras
entendiendo que el proceso nace cuando quien tiene la necesidad la informa de
manera formal y muere con la entrega del o los insumos.
Para lo anterior se determinó que el proceso en su teoría lineal debería de seguir más o menos la siguiente lógica:
01) Nace el proceso con el pedido de materiales:
05) Luego un aporte del Comprador:
06) El aporte de los contables:
Para lo anterior se determinó que el proceso en su teoría lineal debería de seguir más o menos la siguiente lógica:
01) Nace el proceso con el pedido de materiales:
Quiero saber:
02) Una vez decidido el proveedor se genera una orden de compra:
- Cuando se generó la orden de pedido?
- Que numero se le asignó a la orden de pedido?
- Para cuando me informan que necesitan en obra el material pedido?
- Cuantos presupuestos se generaron para atender la orden de pedido?
Quiero saber:
03) Momento que culmina la dulce espera de recibir lo comprado:
- Que orden/es de compra se asignó a la solicitud?
- Con qué fecha salió la OC?
- Que Fecha se pacto para la entrega?
- Con quién fué el trato comercial?
Quiero saber:
04) Luego el proveedor complementa la información de la compra:
- Se recibió la compra? SI - NO - Falta Remito
- Con que Fecha?
- Hubo reclamos sobre la calidad de la recepción? SI-NO
- La recepción del material fué sellada y firmada por alguien? SI-NO
Quiero saber:
- De que Fecha es la factura?
- Que Numero tiene la Factura?
- Cual es el Concepto de la Factura?
- Cual es el SubTotal de la Factura?
05) Luego un aporte del Comprador:
Quiero saber:
- Que Imputación contable tubo la factura?
- Se verificó el precio Unitario y el sub-total de los comprado con lo facturado?
- La Orden de compra fué aprobada para el pago? SI-NO
06) El aporte de los contables:
Quiero saber:
07) Mis deducciones sobre el proveedor:
- Como se va a pagar esa factura?
- Cuando se va a Pagar?
Quiero saber:
07) Mis deducciones sobre el departamento de compras:
- El proveedor cumplió con su compromiso en tiempos?
- Presentó factura en donde debía?
- La entrega se consiguió en los tiempos que la obra lo proponía?
- Presentó factura luego de los 7 días de la entrega?
- Hubo quejas sobre el producto entregado?
- Fué el mejor proveedor de una terna?
Quiero saber:
08) El Resultado de haber preguntado tanto:
- Hubo Orden de Pedido para generar la compra?
- Compras cumplió con el requerimiento que obra le marcaba?
- Compras comparó precios antes de comprar?
- El tiempo entre la orden de pedido la compra fué menor a 2 días?
- El tiempo entre la factura generada y orden de compra fué menor a 2 días?
La aplicación aparte de informar del estado de cada proceso de compra vigente debía de responder siete preguntas básicas a saber del conjunto de procesos como un todo:
Fue eficiente el departamento de compras en dar el servicio al área de
producción?
1) Los procesos realmente comienzan de manera formal?
2) Las compras son realizadas en los primeros dos días del pedido?
3) Los suministros fueron logrados según requerimientos del área de producción?
2) Las compras son realizadas en los primeros dos días del pedido?
3) Los suministros fueron logrados según requerimientos del área de producción?
Que tan eficiente fueron los proveedores con la responsabilidad que le tocaba?
4) Los proveedores que cumplieron con la fecha requerida?
5) Las compras fueron recibidas a satisfacción?
5) Las compras fueron recibidas a satisfacción?
Fue eficiente el departamento en cuanto a los aspectos económicos?
6) Se hicieron comparaciones de precios?
7) Se dio por finalizado el proceso de manera formal contra un remito?
7) Se dio por finalizado el proceso de manera formal contra un remito?
Entonces, todas estas preguntas debería de evaluarse de manera mensual y poder ser comparadas con su mes predecesor para poder trazar los objetivos a superar y surge:
Panel de Control y Trazabilidad de las Compras y Suministros:
Si te interesa dale al boton G+, comenta, participa...
Y escribime para enviarte el ejemplo!
De AutoCAD a Excel pero... LOS PLANOS!
Alguna vez, por el año 1999 tuve la suerte de conocer un ingeniero muy prestigioso y una de las tantas sorpresas que tuve de el fue cuando me enseño sus proyectos realizados en Excel '97... el criterio era lógico, en una pestaña el proyecto, en otra el presupuesto y todo en el mismo archivo para evitar confusiones. Mi primer impresión fue que el fin no justificaba los medios y en aquel momento recuerdo que yo quería enseñarle AutoCAD a quien se cruzara por delante por lo que el sistema me resultó muy interesante pero no ayudaría a mi economía.
Con el pasar los años conocí gente y cada vez mas gente que hasta sus cartas las escribía en Excel, y fue aquí donde surgió esta idea... Una macro que DIBUJA PLANOS DE AUTOCAD EN EXCEL.
La aplicación directa de esto apareció cuando me plantearon la posibilidad real de distribuir información gráfica dentro de una corporación donde la consigna era que ellos puedan en Excel hacer anotaciones y cálculos sobre los planos.
Aquí la concepción de la aplicación:
El sistema para lograr esto es demasiado simple, seleccionar el plano en AutoCAD y esperar un ratito. La devolución es el plano dibujado a escala en Excel, las alturas de las filas y los anchos de columnas se acomodan a la geometría del plano para servir de ejes del proyecto.
Y las pruebas:
Un proyecto viejo en AutoCAD del cual fui el dibujante y lo use de ejemplo para ensayar!
Y el resultado esperado!
Con una precisión de 0,01 mm en el dibujo!!
De aquí en adelante las utilidades son a su criterio.
Download <~~~~ Ir a la sección de descargas
El código a detalle:
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Agregar un Form con el nombre: "Matriz"
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Agregar un Form con el nombre: "Wait"
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Y los siguientes módulos:
Modulo: "A_Plano":
Option Explicit
Public Sub Run()
Dim Temp_Line As AcadLine
Dim AcaD As Object
Dim Objset As Object
Dim Objent As Object
Dim Select_Object As Object
Dim Bcle1 As Long
Dim Bcle2 As Long
Dim Color_R As Long: Dim Color_G As Long: Dim Color_B As Long
Dim Obj_ID As Long
Dim Formato As String: Formato = "0.0000000000000000"
Dim Max_Y As Double
Dim Min_Y As Double: Min_Y = 0
Dim Media_Y As Double
Dim ExplodeObjects As Variant
Dim RExplode As AcadObject
Dim bcle_2 As Long
B_Config_Listas.Config_listA
Set AcaD = GetObject(, "AutoCAD.Application")
For Each Objset In AcaD.ActiveDocument.SelectionSets
If Objset.Name = "Seleccion" Then: Objset.Delete: Exit For
Next
Set Objset = AcaD.ActiveDocument.SelectionSets.Add("Seleccion"): Objset.SelectOnScreen
For Bcle1 = 1 To Objset.Count
Set Objent = Objset.Item(Bcle1 - 1)
Select Case Objent.ObjectName
Case "AcDbLine" ' '"AcDb2dPolyline" ,"AcDbPolyline"
Set Temp_Line = Objent
If Min_Y = 0 Then Min_Y = Temp_Line.StartPoint(1)
If Temp_Line.StartPoint(1) > Max_Y Then Max_Y = Temp_Line.StartPoint(1)
If Temp_Line.EndPoint(1) > Max_Y Then Max_Y = Temp_Line.EndPoint(1)
If Temp_Line.StartPoint(1) < Min_Y Then Min_Y = Temp_Line.StartPoint(1)
If Temp_Line.EndPoint(1) < Min_Y Then Min_Y = Temp_Line.EndPoint(1)
Case "AcDbPolyline"
ExplodeObjects = Objent.Explode
For bcle_2 = 0 To UBound(ExplodeObjects)
Set RExplode = ExplodeObjects(bcle_2)
If RExplode.ObjectName = "AcDbLine" Then
Set Temp_Line = RExplode
If Min_Y = 0 Then Min_Y = Temp_Line.StartPoint(1)
If Temp_Line.StartPoint(1) > Max_Y Then Max_Y = Temp_Line.StartPoint(1)
If Temp_Line.EndPoint(1) > Max_Y Then Max_Y = Temp_Line.EndPoint(1)
If Temp_Line.StartPoint(1) < Min_Y Then Min_Y = Temp_Line.StartPoint(1)
If Temp_Line.EndPoint(1) < Min_Y Then Min_Y = Temp_Line.EndPoint(1)
End If
RExplode.Delete
Next
End Select
Next
Media_Y = (((Max_Y - Min_Y) / 2) + Min_Y)
For Bcle1 = 1 To Objset.Count
Set Objent = Objset.Item(Bcle1 - 1)
Obj_ID = Objent.ObjectID32
Color_R = Objent.TrueColor.Red: Color_G = Objent.TrueColor.Green: Color_B = Objent.TrueColor.Blue
Select Case Objent.ObjectName
Case "AcDbLine"
C_To_Object.Object Obj_ID, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Case "AcDbPolyline"
ExplodeObjects = Objent.Explode
For bcle_2 = 0 To UBound(ExplodeObjects)
Set RExplode = ExplodeObjects(bcle_2)
C_To_Object.Object RExplode.ObjectID32, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Next
Case "AcDbArc": C_To_Object.Object Obj_ID, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Case "AcDbCircle": C_To_Object.Object Obj_ID, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Case "AcDbText": C_To_Object.Object Obj_ID, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Case "AcDbMText":C_To_Object.Object Obj_ID, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Case Else: 'MsgBox Objent.ObjectName
End Select
Next
D_Resumen_Coordenadas.Resumir
E_To_Excel.Run
Coordenadas.Show
End Sub
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Modulo: "B_Config_Listas":
Public Function Config_listA()
With Coordenadas.O_Linea
.ColumnHeaders.Add 1, , "Type", 60
.ColumnHeaders.Add 2, , "ID", 40
.ColumnHeaders.Add 3, , "Start_X", 70
.ColumnHeaders.Add 4, , "Start_Y", 70
.ColumnHeaders.Add 5, , "Finish_X", 70
.ColumnHeaders.Add 6, , "Finish_Y", 70
.ColumnHeaders.Add 7, , "Color_R", 20
.ColumnHeaders.Add 8, , "Color_G", 20
.ColumnHeaders.Add 9, , "Color_B", 20
.ColumnHeaders.Add 10, , "Center_X", 40
.ColumnHeaders.Add 11, , "Center_Y", 40
.ColumnHeaders.Add 12, , "Radius", 40
.ColumnHeaders.Add 13, , "Angulo_Inicio", 40
.ColumnHeaders.Add 14, , "Angulo_Fin", 40
.ColumnHeaders.Add 15, , "Text", 40
.Sorted = True
.ListItems.Clear
.SortOrder = lvwAscending
End With
End Function
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Dim Obj_Generic As Object
Dim Temp_Obj As Object
Dim Simetria_1(0 To 2) As Double
Dim Simetria_2(0 To 2) As Double
Public Function Object(Temp_Id As Long, Obj_ID As Long, Color_R As Long, Color_G As Long, Color_B As Long, Media_Y As Double)
'Capturo el objeto
Set Obj_Generic = AutoCAD.AcadApplication.ActiveDocument.ObjectIdToObject32(Temp_Id)
'Defino Simetria
Simetria_1(0) = 0: Simetria_1(1) = Media_Y: Simetria_1(2) = 0
Simetria_2(0) = 1: Simetria_2(1) = Media_Y: Simetria_2(2) = 0
Set Temp_Obj = Obj_Generic.Mirror(Simetria_1, Simetria_2)
'Vuelco propiedades
Select Case Temp_Obj.ObjectName
Case "AcDbLine"
Dim Ac_Line As AcadLine: Set Ac_Line = Temp_Obj
With Coordenadas.O_Linea.ListItems.Add(, , Ac_Line.ObjectName)
.SubItems(1) = Obj_ID
.SubItems(2) = Ac_Line.StartPoint(0)
.SubItems(3) = Ac_Line.StartPoint(1)
.SubItems(4) = Ac_Line.EndPoint(0)
.SubItems(5) = Ac_Line.EndPoint(1)
.SubItems(6) = Color_R: .SubItems(7) = Color_G: .SubItems(8) = Color_B
End With
Case "AcDbArc"
Dim Obj_Arc As AcadArc: Set Obj_Arc = Temp_Obj
With Coordenadas.O_Linea.ListItems.Add(, , Obj_Arc.ObjectName)
.SubItems(1) = Obj_ID
.SubItems(6) = Color_R: .SubItems(7) = Color_G: .SubItems(8) = Color_B
.SubItems(9) = Obj_Arc.Center(0)
.SubItems(10) = Obj_Arc.Center(1)
.SubItems(11) = Obj_Arc.Radius
.SubItems(12) = Obj_Arc.StartAngle 'este lo dibuja bien
.SubItems(13) = Obj_Arc.EndAngle
.SubItems(2) = Obj_Arc.StartPoint(0)
.SubItems(3) = Obj_Arc.StartPoint(1)
.SubItems(4) = Obj_Arc.EndPoint(0)
.SubItems(5) = Obj_Arc.EndPoint(1)
End With
Case "AcDbCircle"
Dim Obj_Circle As AcadCircle: Set Obj_Circle = Temp_Obj
With Coordenadas.O_Linea.ListItems.Add(, , Obj_Circle.ObjectName)
.SubItems(1) = Obj_ID
.SubItems(6) = Color_R: .SubItems(7) = Color_G: .SubItems(8) = Color_B
.SubItems(9) = Obj_Circle.Center(0)
.SubItems(10) = Obj_Circle.Center(1)
.SubItems(11) = Obj_Circle.Radius
End With
Case "AcDbText"
Dim Obj_Text As AcadText: Set Obj_Text = Temp_Obj
With Coordenadas.O_Linea.ListItems.Add(, , Obj_Text.ObjectName)
.SubItems(1) = Obj_ID
.SubItems(2) = Obj_Text.InsertionPoint(0)
.SubItems(3) = Obj_Text.InsertionPoint(1)
.SubItems(6) = Color_R: .SubItems(7) = Color_G: .SubItems(8) = Color_B
.SubItems(11) = Obj_Text.Height
.SubItems(12) = Obj_Text.Rotation
.SubItems(14) = Obj_Text.TextString
End With
Case "AcDbMText"
Dim Obj_MText As AcadMText: Set Obj_MText = Temp_Obj
With Coordenadas.O_Linea.ListItems.Add(, , Obj_MText.ObjectName)
.SubItems(1) = Obj_ID
.SubItems(2) = Obj_MText.InsertionPoint(0)
.SubItems(3) = Obj_MText.InsertionPoint(1)
.SubItems(6) = Color_R: .SubItems(7) = Color_G: .SubItems(8) = Color_B
.SubItems(11) = Obj_MText.Height
.SubItems(12) = Obj_MText.Rotation
.SubItems(14) = Obj_MText.TextString
End With
End Select
Temp_Obj.Delete
End Function
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Const Escala = 10
Dim Bcle As Long
Dim Bcle2 As Long
Public Sub Resumir()
With Coordenadas.X
.ColumnHeaders.Add 1, "Total", "X", 30
.ColumnHeaders.Add 2, "Parcial", "Xp", 30
.Sorted = True
.SortOrder = lvwAscending
.ListItems.Clear
.ZOrder (1)
End With
With Coordenadas.Y
.ColumnHeaders.Add 1, "Total", "Y", 30
.ColumnHeaders.Add 2, "Parcial", "Yp", 30
.Sorted = True
.SortOrder = lvwAscending
.ListItems.Clear
.ZOrder (1)
End With
For Bcle = 1 To Coordenadas.O_Linea.ListItems.Count
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(2) = Empty Then: Coordenadas.X.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(2), "000000.00000000000")
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(4) = Empty Then: Coordenadas.X.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(4), "000000.00000000000")
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(9) = Empty Then: Coordenadas.X.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(9), "000000.00000000000")
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(3) = Empty Then: Coordenadas.Y.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(3), "000000.00000000000")
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(5) = Empty Then: Coordenadas.Y.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(5), "000000.00000000000")
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(10) = Empty Then: Coordenadas.Y.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(10), "000000.00000000000")
Next
With Coordenadas.X.ListItems
For Bcle2 = .Count To 2 Step -1
If Val(.Item(Bcle2)) = Val(.Item(Bcle2 - 1)) Then .Remove Bcle2
Next
For Bcle2 = 1 To .Count
If Bcle2 = 1 Then .Item(Bcle2).SubItems(1) = FormatNumber(.Item(Bcle2).Text, 4)
If Bcle2 > 1 Then .Item(Bcle2).SubItems(1) = FormatNumber(.Item(Bcle2).Text, 4) - FormatNumber(.Item(Bcle2 - 1).Text, 4)
Next
End With
Coordenadas.X.ColumnHeaders(1).Width = 0
With Coordenadas.Y.ListItems
For Bcle2 = .Count To 2 Step -1
If Val(.Item(Bcle2)) = Val(.Item(Bcle2 - 1)) Then .Remove Bcle2
Next
For Bcle2 = 1 To .Count
If Bcle2 = 1 Then .Item(Bcle2).SubItems(1) = FormatNumber(.Item(Bcle2).Text, 4)
If Bcle2 > 1 Then .Item(Bcle2).SubItems(1) = FormatNumber(.Item(Bcle2).Text, 4) - FormatNumber(.Item(Bcle2 - 1).Text, 4)
Next
End With
Coordenadas.Y.ColumnHeaders(1).Width = 0
End Sub
Modulo: "E_To_Excel"
Dim Color_R As Long
Dim ID As String
Dim Fin_X As Integer
Dim Ini_Y As Integer
Dim Ini_X As Integer
Dim Fin_Y As Integer
Dim Cen_X As Integer
Dim Cen_Y As Integer
Dim Radius As Integer
Dim Ang_Ini As Double
Dim Ang_Med As Double
Dim Ang_Fin As Double
Dim Orient_Reloj As Boolean
Dim Texto As String
Dim FACTOR_ESCALA As Double: FACTOR_ESCALA = 100
Dim Bcle As Long
Dim Obj_Exl As Shape
Dim Bcle2 As Long
Dim Temp_Line As AcadLine
Dim Temp_Point_Center(0 To 2) As Double
Dim Temp_Point_Fin(0 To 2) As Double
Dim Dibujo As Boolean
Dim Un_Sexto As Double
Dim Sub_Point(1 To 10, 1 To 2) As Double
Set apexcel = CreateObject("Excel.application") 'Creates an object
apexcel.Visible = False ' So you can see Excel
apexcel.Workbooks.Add 'Adds a new book.
apexcel.Visible = True
Const Point = 1 ' o escala de puntos
Puntos = Puntos * Point
apexcel.Application.ScreenUpdating = False
With Coordenadas.X
For Bcle = 1 To .ListItems.Count
On Error Resume Next
apexcel.ActiveSheet.Cells(1, Bcle).EntireColumn.ColumnWidth = ((Val(Replace(.ListItems(Bcle).SubItems(1), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA) - 3.75) / 5.25
Next
End With
With Coordenadas.Y
For Bcle = 1 To .ListItems.Count
apexcel.ActiveSheet.Cells(Bcle, 1).EntireRow.RowHeight = ((Val(Replace(.ListItems(Bcle).SubItems(1), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA))
Next
End With
With Coordenadas.O_Linea.ListItems
For Bcle1 = 1 To .Count
ID = .Item(Bcle1).SubItems(1)
Ini_X = Val(Replace(.Item(Bcle1).SubItems(2), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Ini_Y = Val(Replace(.Item(Bcle1).SubItems(3), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Fin_X = Val(Replace(.Item(Bcle1).SubItems(4), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Fin_Y = Val(Replace(.Item(Bcle1).SubItems(5), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Color_R = Val(Replace(.Item(Bcle1).SubItems(6), ",", ".", , , vbTextCompare))
Color_G = Val(Replace(.Item(Bcle1).SubItems(7), ",", ".", , , vbTextCompare))
Color_B = Val(Replace(.Item(Bcle1).SubItems(8), ",", ".", , , vbTextCompare))
Cen_X = Val(Replace(.Item(Bcle1).SubItems(9), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Cen_Y = Val(Replace(.Item(Bcle1).SubItems(10), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Radius = Val(Replace(.Item(Bcle1).SubItems(11), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Ang_Ini = Val(Replace(.Item(Bcle1).SubItems(12), ",", ".", , , vbTextCompare))
Ang_Fin = Val(Replace(.Item(Bcle1).SubItems(13), ",", ".", , , vbTextCompare))
Texto = .Item(Bcle1).SubItems(14)
Pi = 4 * Atn(1)
Dibujo = False
Temp_Point_Center(0) = Cen_X / FACTOR_ESCALA: Temp_Point_Center(1) = Cen_Y / FACTOR_ESCALA: Temp_Point_Center(2) = 0
Select Case .Item(Bcle1)
Case "AcDbLine"
Set Obj_Exl = apexcel.ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Ini_X, Ini_Y, Fin_X, Fin_Y)
Obj_Exl.Select
Dibujo = True
Case "AcDbArc"
Dim Start_Arc_X As Double
Dim Start_Arc_Y As Double
If Ang_Ini > Ang_Fin Then
Orient_Reloj = False
Un_Sexto = ((2 * Pi) - (Ang_Ini - Ang_Fin)) / 10
Temp_Point_Fin(0) = Fin_X / FACTOR_ESCALA: Temp_Point_Fin(1) = Fin_Y / FACTOR_ESCALA: Temp_Point_Fin(2) = 0
Set Temp_Line = AutoCAD.ActiveDocument.ModelSpace.AddLine(Temp_Point_Center, Temp_Point_Fin)
Start_Arc_X = Fin_X
Start_Arc_Y = Fin_I
For Bcle2 = 1 To 10
Call Temp_Line.Rotate(Temp_Point_Center, -Un_Sexto)
Sub_Point(Bcle2, 1) = Temp_Line.EndPoint(0) * FACTOR_ESCALA
Sub_Point(Bcle2, 2) = Temp_Line.EndPoint(1) * FACTOR_ESCALA
Next
Temp_Line.Delete
With apexcel.ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Fin_X, Fin_Y)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(1, 1), Sub_Point(1, 2), Sub_Point(2, 1), Sub_Point(2, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(3, 1), Sub_Point(3, 2), Sub_Point(4, 1), Sub_Point(4, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(5, 1), Sub_Point(5, 2), Sub_Point(6, 1), Sub_Point(6, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(7, 1), Sub_Point(7, 2), Sub_Point(8, 1), Sub_Point(8, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(9, 1), Sub_Point(9, 2), Sub_Point(10, 1), Sub_Point(10, 2)
.ConvertToShape.Select
End With
Set Obj_Exl = apexcel.ActiveSheet.Shapes(apexcel.Selection.Name)
Dibujo = True
Else
Orient_Reloj = True ' Este lo dibuja bien
Un_Sexto = (Ang_Fin - Ang_Ini) / 10
Temp_Point_Fin(0) = Ini_X / FACTOR_ESCALA: Temp_Point_Fin(1) = Ini_Y / FACTOR_ESCALA: Temp_Point_Fin(2) = 0
Set Temp_Line = AutoCAD.ActiveDocument.ModelSpace.AddLine(Temp_Point_Center, Temp_Point_Fin)
Start_Arc_X = Ini_X
Start_Arc_Y = Ini_I
For Bcle2 = 1 To 10
Call Temp_Line.Rotate(Temp_Point_Center, Un_Sexto)
Sub_Point(Bcle2, 1) = Temp_Line.EndPoint(0) * FACTOR_ESCALA
Sub_Point(Bcle2, 2) = Temp_Line.EndPoint(1) * FACTOR_ESCALA
Next
Temp_Line.Delete
With apexcel.ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Ini_X, Ini_Y)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(1, 1), Sub_Point(1, 2), Sub_Point(2, 1), Sub_Point(2, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(3, 1), Sub_Point(3, 2), Sub_Point(4, 1), Sub_Point(4, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(5, 1), Sub_Point(5, 2), Sub_Point(6, 1), Sub_Point(6, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(7, 1), Sub_Point(7, 2), Sub_Point(8, 1), Sub_Point(8, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(9, 1), Sub_Point(9, 2), Sub_Point(10, 1), Sub_Point(10, 2)
.ConvertToShape.Select
End With
Set Obj_Exl = apexcel.ActiveSheet.Shapes(apexcel.Selection.Name)
Dibujo = True
End If
Case "AcDbCircle"
Set Obj_Exl = apexcel.ActiveSheet.Shapes.AddShape(msoShapeOval, Cen_X - Radius, Cen_Y - Radius, Radius * 2, Radius * 2)
Dibujo = True
Case "AcDbMText", "AcDbText"
apexcel.ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Ini_X, Ini_Y, Radius * Len(Texto), Radius).Select
apexcel.Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Texto
apexcel.Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6).ParagraphFormat.FirstLineIndent = 0
With apexcel.Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.transparency = 0
.Fill.Solid
.Size = Radius
.Name = "+mn-lt"
End With
apexcel.Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
End Select
If Dibujo = True Then
With Obj_Exl
.Visible = msoTrue
.Placement = xlFreeFloating
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(Color_R, Color_G, Color_B)
.Line.Weight = 0.5
.Line.transparency = 0
.Line.ForeColor.Brightness = 0
.Line.ForeColor.TintAndShade = 0
End With
End If
Next
End With
apexcel.Application.ScreenUpdating = True
End Sub
Con el pasar los años conocí gente y cada vez mas gente que hasta sus cartas las escribía en Excel, y fue aquí donde surgió esta idea... Una macro que DIBUJA PLANOS DE AUTOCAD EN EXCEL.
La aplicación directa de esto apareció cuando me plantearon la posibilidad real de distribuir información gráfica dentro de una corporación donde la consigna era que ellos puedan en Excel hacer anotaciones y cálculos sobre los planos.
Aquí la concepción de la aplicación:
El sistema para lograr esto es demasiado simple, seleccionar el plano en AutoCAD y esperar un ratito. La devolución es el plano dibujado a escala en Excel, las alturas de las filas y los anchos de columnas se acomodan a la geometría del plano para servir de ejes del proyecto.
Y las pruebas:
Un proyecto viejo en AutoCAD del cual fui el dibujante y lo use de ejemplo para ensayar!
Y el resultado esperado!
Con una precisión de 0,01 mm en el dibujo!!
De aquí en adelante las utilidades son a su criterio.
Download <~~~~ Ir a la sección de descargas
El código a detalle:
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Agregar un Form con el nombre: "Matriz"
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Modulo: "A_Plano":
Option Explicit
Public Sub Run()
Dim Temp_Line As AcadLine
Dim AcaD As Object
Dim Objset As Object
Dim Objent As Object
Dim Select_Object As Object
Dim Bcle1 As Long
Dim Bcle2 As Long
Dim Color_R As Long: Dim Color_G As Long: Dim Color_B As Long
Dim Obj_ID As Long
Dim Formato As String: Formato = "0.0000000000000000"
Dim Max_Y As Double
Dim Min_Y As Double: Min_Y = 0
Dim Media_Y As Double
Dim ExplodeObjects As Variant
Dim RExplode As AcadObject
Dim bcle_2 As Long
B_Config_Listas.Config_listA
Set AcaD = GetObject(, "AutoCAD.Application")
For Each Objset In AcaD.ActiveDocument.SelectionSets
If Objset.Name = "Seleccion" Then: Objset.Delete: Exit For
Next
Set Objset = AcaD.ActiveDocument.SelectionSets.Add("Seleccion"): Objset.SelectOnScreen
For Bcle1 = 1 To Objset.Count
Set Objent = Objset.Item(Bcle1 - 1)
Select Case Objent.ObjectName
Case "AcDbLine" ' '"AcDb2dPolyline" ,"AcDbPolyline"
Set Temp_Line = Objent
If Min_Y = 0 Then Min_Y = Temp_Line.StartPoint(1)
If Temp_Line.StartPoint(1) > Max_Y Then Max_Y = Temp_Line.StartPoint(1)
If Temp_Line.EndPoint(1) > Max_Y Then Max_Y = Temp_Line.EndPoint(1)
If Temp_Line.StartPoint(1) < Min_Y Then Min_Y = Temp_Line.StartPoint(1)
If Temp_Line.EndPoint(1) < Min_Y Then Min_Y = Temp_Line.EndPoint(1)
Case "AcDbPolyline"
ExplodeObjects = Objent.Explode
For bcle_2 = 0 To UBound(ExplodeObjects)
Set RExplode = ExplodeObjects(bcle_2)
If RExplode.ObjectName = "AcDbLine" Then
Set Temp_Line = RExplode
If Min_Y = 0 Then Min_Y = Temp_Line.StartPoint(1)
If Temp_Line.StartPoint(1) > Max_Y Then Max_Y = Temp_Line.StartPoint(1)
If Temp_Line.EndPoint(1) > Max_Y Then Max_Y = Temp_Line.EndPoint(1)
If Temp_Line.StartPoint(1) < Min_Y Then Min_Y = Temp_Line.StartPoint(1)
If Temp_Line.EndPoint(1) < Min_Y Then Min_Y = Temp_Line.EndPoint(1)
End If
RExplode.Delete
Next
End Select
Next
Media_Y = (((Max_Y - Min_Y) / 2) + Min_Y)
For Bcle1 = 1 To Objset.Count
Set Objent = Objset.Item(Bcle1 - 1)
Obj_ID = Objent.ObjectID32
Color_R = Objent.TrueColor.Red: Color_G = Objent.TrueColor.Green: Color_B = Objent.TrueColor.Blue
Select Case Objent.ObjectName
Case "AcDbLine"
C_To_Object.Object Obj_ID, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Case "AcDbPolyline"
ExplodeObjects = Objent.Explode
For bcle_2 = 0 To UBound(ExplodeObjects)
Set RExplode = ExplodeObjects(bcle_2)
C_To_Object.Object RExplode.ObjectID32, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Next
Case "AcDbArc": C_To_Object.Object Obj_ID, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Case "AcDbCircle": C_To_Object.Object Obj_ID, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Case "AcDbText": C_To_Object.Object Obj_ID, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Case "AcDbMText":C_To_Object.Object Obj_ID, Obj_ID, Color_R, Color_G, Color_B, Media_Y
Case Else: 'MsgBox Objent.ObjectName
End Select
Next
D_Resumen_Coordenadas.Resumir
E_To_Excel.Run
Coordenadas.Show
End Sub
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Modulo: "B_Config_Listas":
Public Function Config_listA()
With Coordenadas.O_Linea
.ColumnHeaders.Add 1, , "Type", 60
.ColumnHeaders.Add 2, , "ID", 40
.ColumnHeaders.Add 3, , "Start_X", 70
.ColumnHeaders.Add 4, , "Start_Y", 70
.ColumnHeaders.Add 5, , "Finish_X", 70
.ColumnHeaders.Add 6, , "Finish_Y", 70
.ColumnHeaders.Add 7, , "Color_R", 20
.ColumnHeaders.Add 8, , "Color_G", 20
.ColumnHeaders.Add 9, , "Color_B", 20
.ColumnHeaders.Add 10, , "Center_X", 40
.ColumnHeaders.Add 11, , "Center_Y", 40
.ColumnHeaders.Add 12, , "Radius", 40
.ColumnHeaders.Add 13, , "Angulo_Inicio", 40
.ColumnHeaders.Add 14, , "Angulo_Fin", 40
.ColumnHeaders.Add 15, , "Text", 40
.Sorted = True
.ListItems.Clear
.SortOrder = lvwAscending
End With
End Function
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Modulo:"C_To_Object":
Option ExplicitDim Obj_Generic As Object
Dim Temp_Obj As Object
Dim Simetria_1(0 To 2) As Double
Dim Simetria_2(0 To 2) As Double
Public Function Object(Temp_Id As Long, Obj_ID As Long, Color_R As Long, Color_G As Long, Color_B As Long, Media_Y As Double)
'Capturo el objeto
Set Obj_Generic = AutoCAD.AcadApplication.ActiveDocument.ObjectIdToObject32(Temp_Id)
'Defino Simetria
Simetria_1(0) = 0: Simetria_1(1) = Media_Y: Simetria_1(2) = 0
Simetria_2(0) = 1: Simetria_2(1) = Media_Y: Simetria_2(2) = 0
Set Temp_Obj = Obj_Generic.Mirror(Simetria_1, Simetria_2)
'Vuelco propiedades
Select Case Temp_Obj.ObjectName
Case "AcDbLine"
Dim Ac_Line As AcadLine: Set Ac_Line = Temp_Obj
With Coordenadas.O_Linea.ListItems.Add(, , Ac_Line.ObjectName)
.SubItems(1) = Obj_ID
.SubItems(2) = Ac_Line.StartPoint(0)
.SubItems(3) = Ac_Line.StartPoint(1)
.SubItems(4) = Ac_Line.EndPoint(0)
.SubItems(5) = Ac_Line.EndPoint(1)
.SubItems(6) = Color_R: .SubItems(7) = Color_G: .SubItems(8) = Color_B
End With
Case "AcDbArc"
Dim Obj_Arc As AcadArc: Set Obj_Arc = Temp_Obj
With Coordenadas.O_Linea.ListItems.Add(, , Obj_Arc.ObjectName)
.SubItems(1) = Obj_ID
.SubItems(6) = Color_R: .SubItems(7) = Color_G: .SubItems(8) = Color_B
.SubItems(9) = Obj_Arc.Center(0)
.SubItems(10) = Obj_Arc.Center(1)
.SubItems(11) = Obj_Arc.Radius
.SubItems(12) = Obj_Arc.StartAngle 'este lo dibuja bien
.SubItems(13) = Obj_Arc.EndAngle
.SubItems(2) = Obj_Arc.StartPoint(0)
.SubItems(3) = Obj_Arc.StartPoint(1)
.SubItems(4) = Obj_Arc.EndPoint(0)
.SubItems(5) = Obj_Arc.EndPoint(1)
End With
Case "AcDbCircle"
Dim Obj_Circle As AcadCircle: Set Obj_Circle = Temp_Obj
With Coordenadas.O_Linea.ListItems.Add(, , Obj_Circle.ObjectName)
.SubItems(1) = Obj_ID
.SubItems(6) = Color_R: .SubItems(7) = Color_G: .SubItems(8) = Color_B
.SubItems(9) = Obj_Circle.Center(0)
.SubItems(10) = Obj_Circle.Center(1)
.SubItems(11) = Obj_Circle.Radius
End With
Case "AcDbText"
Dim Obj_Text As AcadText: Set Obj_Text = Temp_Obj
With Coordenadas.O_Linea.ListItems.Add(, , Obj_Text.ObjectName)
.SubItems(1) = Obj_ID
.SubItems(2) = Obj_Text.InsertionPoint(0)
.SubItems(3) = Obj_Text.InsertionPoint(1)
.SubItems(6) = Color_R: .SubItems(7) = Color_G: .SubItems(8) = Color_B
.SubItems(11) = Obj_Text.Height
.SubItems(12) = Obj_Text.Rotation
.SubItems(14) = Obj_Text.TextString
End With
Case "AcDbMText"
Dim Obj_MText As AcadMText: Set Obj_MText = Temp_Obj
With Coordenadas.O_Linea.ListItems.Add(, , Obj_MText.ObjectName)
.SubItems(1) = Obj_ID
.SubItems(2) = Obj_MText.InsertionPoint(0)
.SubItems(3) = Obj_MText.InsertionPoint(1)
.SubItems(6) = Color_R: .SubItems(7) = Color_G: .SubItems(8) = Color_B
.SubItems(11) = Obj_MText.Height
.SubItems(12) = Obj_MText.Rotation
.SubItems(14) = Obj_MText.TextString
End With
End Select
Temp_Obj.Delete
End Function
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Modulo: D_Resumen_Coordenadas
Option ExplicitConst Escala = 10
Dim Bcle As Long
Dim Bcle2 As Long
Public Sub Resumir()
With Coordenadas.X
.ColumnHeaders.Add 1, "Total", "X", 30
.ColumnHeaders.Add 2, "Parcial", "Xp", 30
.Sorted = True
.SortOrder = lvwAscending
.ListItems.Clear
.ZOrder (1)
End With
With Coordenadas.Y
.ColumnHeaders.Add 1, "Total", "Y", 30
.ColumnHeaders.Add 2, "Parcial", "Yp", 30
.Sorted = True
.SortOrder = lvwAscending
.ListItems.Clear
.ZOrder (1)
End With
For Bcle = 1 To Coordenadas.O_Linea.ListItems.Count
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(2) = Empty Then: Coordenadas.X.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(2), "000000.00000000000")
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(4) = Empty Then: Coordenadas.X.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(4), "000000.00000000000")
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(9) = Empty Then: Coordenadas.X.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(9), "000000.00000000000")
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(3) = Empty Then: Coordenadas.Y.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(3), "000000.00000000000")
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(5) = Empty Then: Coordenadas.Y.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(5), "000000.00000000000")
If Not Coordenadas.O_Linea.ListItems(Bcle).SubItems(10) = Empty Then: Coordenadas.Y.ListItems.Add , , Format(Coordenadas.O_Linea.ListItems(Bcle).SubItems(10), "000000.00000000000")
Next
With Coordenadas.X.ListItems
For Bcle2 = .Count To 2 Step -1
If Val(.Item(Bcle2)) = Val(.Item(Bcle2 - 1)) Then .Remove Bcle2
Next
For Bcle2 = 1 To .Count
If Bcle2 = 1 Then .Item(Bcle2).SubItems(1) = FormatNumber(.Item(Bcle2).Text, 4)
If Bcle2 > 1 Then .Item(Bcle2).SubItems(1) = FormatNumber(.Item(Bcle2).Text, 4) - FormatNumber(.Item(Bcle2 - 1).Text, 4)
Next
End With
Coordenadas.X.ColumnHeaders(1).Width = 0
With Coordenadas.Y.ListItems
For Bcle2 = .Count To 2 Step -1
If Val(.Item(Bcle2)) = Val(.Item(Bcle2 - 1)) Then .Remove Bcle2
Next
For Bcle2 = 1 To .Count
If Bcle2 = 1 Then .Item(Bcle2).SubItems(1) = FormatNumber(.Item(Bcle2).Text, 4)
If Bcle2 > 1 Then .Item(Bcle2).SubItems(1) = FormatNumber(.Item(Bcle2).Text, 4) - FormatNumber(.Item(Bcle2 - 1).Text, 4)
Next
End With
Coordenadas.Y.ColumnHeaders(1).Width = 0
End Sub
Modulo: "E_To_Excel"
Dim Color_R As Long
Dim ID As String
Dim Fin_X As Integer
Dim Ini_Y As Integer
Dim Ini_X As Integer
Dim Fin_Y As Integer
Dim Cen_X As Integer
Dim Cen_Y As Integer
Dim Radius As Integer
Dim Ang_Ini As Double
Dim Ang_Med As Double
Dim Ang_Fin As Double
Dim Orient_Reloj As Boolean
Dim Texto As String
Dim FACTOR_ESCALA As Double: FACTOR_ESCALA = 100
Dim Bcle As Long
Dim Obj_Exl As Shape
Dim Bcle2 As Long
Dim Temp_Line As AcadLine
Dim Temp_Point_Center(0 To 2) As Double
Dim Temp_Point_Fin(0 To 2) As Double
Dim Dibujo As Boolean
Dim Un_Sexto As Double
Dim Sub_Point(1 To 10, 1 To 2) As Double
Set apexcel = CreateObject("Excel.application") 'Creates an object
apexcel.Visible = False ' So you can see Excel
apexcel.Workbooks.Add 'Adds a new book.
apexcel.Visible = True
Const Point = 1 ' o escala de puntos
Puntos = Puntos * Point
apexcel.Application.ScreenUpdating = False
With Coordenadas.X
For Bcle = 1 To .ListItems.Count
On Error Resume Next
apexcel.ActiveSheet.Cells(1, Bcle).EntireColumn.ColumnWidth = ((Val(Replace(.ListItems(Bcle).SubItems(1), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA) - 3.75) / 5.25
Next
End With
With Coordenadas.Y
For Bcle = 1 To .ListItems.Count
apexcel.ActiveSheet.Cells(Bcle, 1).EntireRow.RowHeight = ((Val(Replace(.ListItems(Bcle).SubItems(1), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA))
Next
End With
With Coordenadas.O_Linea.ListItems
For Bcle1 = 1 To .Count
ID = .Item(Bcle1).SubItems(1)
Ini_X = Val(Replace(.Item(Bcle1).SubItems(2), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Ini_Y = Val(Replace(.Item(Bcle1).SubItems(3), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Fin_X = Val(Replace(.Item(Bcle1).SubItems(4), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Fin_Y = Val(Replace(.Item(Bcle1).SubItems(5), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Color_R = Val(Replace(.Item(Bcle1).SubItems(6), ",", ".", , , vbTextCompare))
Color_G = Val(Replace(.Item(Bcle1).SubItems(7), ",", ".", , , vbTextCompare))
Color_B = Val(Replace(.Item(Bcle1).SubItems(8), ",", ".", , , vbTextCompare))
Cen_X = Val(Replace(.Item(Bcle1).SubItems(9), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Cen_Y = Val(Replace(.Item(Bcle1).SubItems(10), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Radius = Val(Replace(.Item(Bcle1).SubItems(11), ",", ".", , , vbTextCompare)) * FACTOR_ESCALA
Ang_Ini = Val(Replace(.Item(Bcle1).SubItems(12), ",", ".", , , vbTextCompare))
Ang_Fin = Val(Replace(.Item(Bcle1).SubItems(13), ",", ".", , , vbTextCompare))
Texto = .Item(Bcle1).SubItems(14)
Pi = 4 * Atn(1)
Dibujo = False
Temp_Point_Center(0) = Cen_X / FACTOR_ESCALA: Temp_Point_Center(1) = Cen_Y / FACTOR_ESCALA: Temp_Point_Center(2) = 0
Select Case .Item(Bcle1)
Case "AcDbLine"
Set Obj_Exl = apexcel.ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Ini_X, Ini_Y, Fin_X, Fin_Y)
Obj_Exl.Select
Dibujo = True
Case "AcDbArc"
Dim Start_Arc_X As Double
Dim Start_Arc_Y As Double
If Ang_Ini > Ang_Fin Then
Orient_Reloj = False
Un_Sexto = ((2 * Pi) - (Ang_Ini - Ang_Fin)) / 10
Temp_Point_Fin(0) = Fin_X / FACTOR_ESCALA: Temp_Point_Fin(1) = Fin_Y / FACTOR_ESCALA: Temp_Point_Fin(2) = 0
Set Temp_Line = AutoCAD.ActiveDocument.ModelSpace.AddLine(Temp_Point_Center, Temp_Point_Fin)
Start_Arc_X = Fin_X
Start_Arc_Y = Fin_I
For Bcle2 = 1 To 10
Call Temp_Line.Rotate(Temp_Point_Center, -Un_Sexto)
Sub_Point(Bcle2, 1) = Temp_Line.EndPoint(0) * FACTOR_ESCALA
Sub_Point(Bcle2, 2) = Temp_Line.EndPoint(1) * FACTOR_ESCALA
Next
Temp_Line.Delete
With apexcel.ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Fin_X, Fin_Y)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(1, 1), Sub_Point(1, 2), Sub_Point(2, 1), Sub_Point(2, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(3, 1), Sub_Point(3, 2), Sub_Point(4, 1), Sub_Point(4, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(5, 1), Sub_Point(5, 2), Sub_Point(6, 1), Sub_Point(6, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(7, 1), Sub_Point(7, 2), Sub_Point(8, 1), Sub_Point(8, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(9, 1), Sub_Point(9, 2), Sub_Point(10, 1), Sub_Point(10, 2)
.ConvertToShape.Select
End With
Set Obj_Exl = apexcel.ActiveSheet.Shapes(apexcel.Selection.Name)
Dibujo = True
Else
Orient_Reloj = True ' Este lo dibuja bien
Un_Sexto = (Ang_Fin - Ang_Ini) / 10
Temp_Point_Fin(0) = Ini_X / FACTOR_ESCALA: Temp_Point_Fin(1) = Ini_Y / FACTOR_ESCALA: Temp_Point_Fin(2) = 0
Set Temp_Line = AutoCAD.ActiveDocument.ModelSpace.AddLine(Temp_Point_Center, Temp_Point_Fin)
Start_Arc_X = Ini_X
Start_Arc_Y = Ini_I
For Bcle2 = 1 To 10
Call Temp_Line.Rotate(Temp_Point_Center, Un_Sexto)
Sub_Point(Bcle2, 1) = Temp_Line.EndPoint(0) * FACTOR_ESCALA
Sub_Point(Bcle2, 2) = Temp_Line.EndPoint(1) * FACTOR_ESCALA
Next
Temp_Line.Delete
With apexcel.ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Ini_X, Ini_Y)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(1, 1), Sub_Point(1, 2), Sub_Point(2, 1), Sub_Point(2, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(3, 1), Sub_Point(3, 2), Sub_Point(4, 1), Sub_Point(4, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(5, 1), Sub_Point(5, 2), Sub_Point(6, 1), Sub_Point(6, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(7, 1), Sub_Point(7, 2), Sub_Point(8, 1), Sub_Point(8, 2)
.AddNodes msoSegmentCurve, msoEditingAuto, Sub_Point(9, 1), Sub_Point(9, 2), Sub_Point(10, 1), Sub_Point(10, 2)
.ConvertToShape.Select
End With
Set Obj_Exl = apexcel.ActiveSheet.Shapes(apexcel.Selection.Name)
Dibujo = True
End If
Case "AcDbCircle"
Set Obj_Exl = apexcel.ActiveSheet.Shapes.AddShape(msoShapeOval, Cen_X - Radius, Cen_Y - Radius, Radius * 2, Radius * 2)
Dibujo = True
Case "AcDbMText", "AcDbText"
apexcel.ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Ini_X, Ini_Y, Radius * Len(Texto), Radius).Select
apexcel.Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Texto
apexcel.Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6).ParagraphFormat.FirstLineIndent = 0
With apexcel.Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.transparency = 0
.Fill.Solid
.Size = Radius
.Name = "+mn-lt"
End With
apexcel.Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
End Select
If Dibujo = True Then
With Obj_Exl
.Visible = msoTrue
.Placement = xlFreeFloating
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(Color_R, Color_G, Color_B)
.Line.Weight = 0.5
.Line.transparency = 0
.Line.ForeColor.Brightness = 0
.Line.ForeColor.TintAndShade = 0
End With
End If
Next
End With
apexcel.Application.ScreenUpdating = True
End Sub
Si te interesa dale al boton G+, comenta, participa...
Y escribime para enviarte el ejemplo!
Suscribirse a:
Entradas (Atom)