Base de datos del autocad

Como puedo graficar a partir de los datos de que tengo en excel con atributos, osea me refiero que tengo coordenadas en POR e Y (ejemplo una linea en ese tramo que me aparezca los atributos que ya tengo llenado en excel) gracias por la respuesta
joserosa.

1 Respuesta

Respuesta
1
Aquí te muestro una manera muy sencilla de realizar lo que pides, asumí que el archivo de excel esta configurado de la siguiente forma:
X Y Texto
X Y
X Y Texto
POR Y
Crea un proyecto de Visual Basic en Autocad, inserta un modulo y copia las lineas de abajo.
Espero esto te sirva, pero de todos modos ponte en contacto conmigo si necesitas más ayuda.
Te recuerdo que esta es la forma más sencilla de hacerlo ya que es muy básica, si necesitas otras cosas contáctame.
Saludos
Sub graficar()
Dim PtoIn(0 To 2) As Double
Dim PtoFin(0 To 2) As Double
Dim Texto As String
Dim PtoIns(0 To 2) As Double
'Conecta con excel
Set App = CreateObject("Excel.Application")
'Abre el archivo - solo cambia por la ruta y nombre de tu archivo -
App.Workbooks.Open FileName:="C:\Book1.xls"
'Visualiza Excel -Si no necesitas Excel visible omite esta linea -
App.Visible = True
'Estoy asumiendo que el archivo esta estructurado de la siguiente manera
'Columna A - coordenada X, Columna B - Coordenada Y, Columna C - Texto
App.Range("A1").Select
PtoIn(0) = App.ActiveCell.Value
'Aqui estoy en B1
App.ActiveCell.Offset(0, 1).Select
PtoIn(1) = App.ActiveCell.Value
'Aqui estoy en C1
App.ActiveCell.Offset(0, 1).Select
Texto = App.ActiveCell.Value
'Aqui estoy en A2
App.ActiveCell.Offset(1, -2).Select
PtoFin(0) = App.ActiveCell.Value
'Aqui estoy en B2
App.ActiveCell.Offset(0, 1).Select
PtoFin(1) = App.ActiveCell.Value
'Aqui se Cierra Excel
App.Quit
'Esto hace un llamado a la rutina NewLine para que dibuje la linea
Call NewLine(PtoIn, PtoFin, "0")
'Ahora calculamos el centro de la linea para insertar el texto
PtoIns(0) = (PtoIn(0) + PtoFin(0)) / 2
PtoIns(1) = (PtoIn(1) + PtoFin(1)) / 2
'Esto hace un llamado a la rutina NewText para que dibuje la texto
Call NewText(Texto, PtoIns, 2, 0, 0, 0, "0")
End Sub
'Esta rutina dibuja lineas y las coloca en un layer creado previamente
'los parametros son los siguientes: AUX1 es el punto inicial
'AUX2 es el punto final, Layer es el nombre del layer donde deseas colocar la linea
Sub NewLine(AUX1() As Double, AUX2() As Double, Layer As String)
Dim ACADDOC As Object
Dim ACADDOCMS As Object
Set ACADDOC = GetObject(, "Autocad.Application").ActiveDocument
Set ACADDOCMS = ACADDOC.ModelSpace
Set ObjLine = ACADDOCMS.AddLine(AUX1, AUX2)
ObjLine.Layer = Layer
ObjLine.Update
End Sub
'Esta rutina inserta textos, los coloca en un layer creado previamente
'los parametros son los siguientes: Text contiene el texto a insertar, AUX es el punto de insercion
'Height contiene la altura que va a tener el texto, THA y THV estas variables controlan la justificacion
'horizontal y vertiucal del texto sus valores son: 0-derecha,arriba; 1-centro,centro; 2-izquierda,abajo
'respectivamente para THA y THV, TR esta variable controla la rotacion del texto, sus valores son 0 y 1
'para 0 y 90 grados respectivamente y Layer ya fue descrito.
Sub NewText(Text As String, AUX() As Double, Height As Double, THA As Integer, TVA As Integer, TR As Integer, Layer As String)
Const Pi As Double = 3.14159265359
Dim ACADDOC As Object
Dim ACADDOCMS As Object
Dim AcadUtil As Object
Dim Pto(0 To 2) As Double
Pto(0) = 0: Pto(1) = 0
Set ACADDOC = GetObject(, "Autocad.Application").ActiveDocument
Set ACADDOCMS = ACADDOC.ModelSpace
Set TextObj = ACADDOCMS.AddText(Text, AUX, Height)
If THA = 0 Then
TextObj.HorizontalAlignment = acHorizontalAlignmentRight
ElseIf THA = 1 Then
TextObj.HorizontalAlignment = acHorizontalAlignmentCenter
ElseIf THA = 2 Then
TextObj.HorizontalAlignment = acHorizontalAlignmentLeft
End If
If TVA = 0 Then
TextObj.VerticalAlignment = acVerticalAlignmentTop
ElseIf TVA = 1 Then
TextObj.VerticalAlignment = acVerticalAlignmentMiddle
ElseIf TVA = 2 Then
TextObj.VerticalAlignment = acVerticalAlignmentBotom
End If
If TR = 1 Then
TextObj.Rotation = Pi / 2
End If
TextObj.Layer = Layer
Call TextObj.Move(Pto, AUX)
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas