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
Hola, buena información, donde obtengo mayor información? Gracias
ResponderEliminarPost Actualizado con el código, a tus ordenes por cualquier consulta!
Eliminarextremamente interesante la utilización de la macro, se puede conocer detalles de la programación?
ResponderEliminarPost Actualizado con el código, a tus ordenes por cualquier consulta!
Eliminarme gustaría disponer del ejemplo y aprender la programación
ResponderEliminarMilton no veo tu correo para enviarte un enlace.
Eliminar