Rutina para autocad

Hola soy ingeniero civil y necesito realizar un plano en autocad, ya esta el levantamiento topográfico de la zona y quiero saber si tienes la rutina para dibujar desde la base de datos de Excel gracias por tu ayuda que tengas un feliz día.

1 respuesta

Respuesta
1
Hace un poco tiempo respondí algunas preguntas parecidas a esta. La respuesta esta realizada para insertar lineas, textos.
Ahora si lo que necesitas es insertar información topográfica cruda, es decir, angulo horizontal, distancia y angulo vertical, te recomiendo que uses Autodesk Land Development para que realices estas tareas. De todas maneras espero que la rutina que te envío te sirva de algo y si por el contrario necesitas información acerca del Land para insertar la información, contáctame de nuevo por aquí o por mi MSN que esta en mi página. Saludos
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