VBA code to generate 3dpoly

[rsalastopografia]

Good evening dear community, I turn to this forum in search of help and a solution to a VBA code. Below I will detail what we are looking to do.
1. I have an Excel sheet with survey coordinate data with the following headings in the columns (Point No., X Coordinate, Y Coordinate, Elevation, Description). I want to create a macro from excel to autocad that inserts all the points (list of points) to autocad with texts of Point numbering, description; Additionally, generate layers in AutoCAD according to the descriptions that may be in the Excel sheet.
2. Regarding the VBA code I was able to create the layers according to the descriptions, in addition to inserting the points; Now what I need is to generate a 3dpoly according to the descriptions of the topographic survey, also for these 3dpoly to assume the layer according to the descriptions.

I hope you understand my message and help me solve this VBA code because it is very important to me; greetings.

[Ed__Jobe]

If you are a professional in the topography field, I highly recommend that you do not use vba in this manner. You should  be at least using AutoCAD Map, or better yet, Civil 3D. They have industry standard tools for this kind of data.

[rsalastopografia]

The objective of the macro is to automatically generate the 3dpoly according to the descriptions of the topographic survey running from Excel, perhaps you do not know the 3d civil tools that can perform this action; greetings.

[-didier-]

Bonjour @rsalastopografia 

Do you really need a VBA macro ?

For doing what you ask, a simple script will do the job.
There are many examples of scripts for inserting points on the forum.

Thanks to explain to us why you require VBA and I will try to help you.

EDIT : Sorry, I misunderstood the question because I just went to see the code.
You need to improve this code by drawing a 3D polyline between these points?

Amicalement

[rsalastopografia]

Gracias por su ayuda, sin embargo logre el objetivo y mi macro funciona tal como describí en este foro. saludos.

[-didier-]

Bonjour @rsalastopografia 

Between the last "Next i" and the "end sub" you have to type this code :

   Next i

Dim dblCoordinates() As Double
Dim FirstRow As Integer
FirstRow = 4 'beginning of arra with the first value of X, you can change this variable if the frist point is not at the line 4
With Sheets("Datos1")
        .Activate
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
ReDim dblCoordinates(1 To 3 * (LastRow - 3))
    k = 1
    For i = FirstRow To LastRow
        For j = 2 To 4 ' I begin with 2 because the first colum is the number of the point, -> 2 X 3 Y 4 Z
            dblCoordinates(k) = Sheets("Datos1").Cells(i, j)
            k = k + 1
        Next j
    Next i
    Set acad3DPol = AutoCAD.ActiveDocument.ModelSpace.Add3DPoly(dblCoordinates)
    acad3DPol.Closed = False
    acad3DPol.Update

End Sub

Amicalement

[rsalastopografia]

Sub InsertPointsAndDraw3DPolylines()

' Declaración de variables para puntos y textos
Dim AutoCAD As Object
Dim pointObj As AcadPoint
Dim textObj As AcadText
Dim descTextObj As AcadText
Dim pto(0 To 2) As Double
Dim textString As String
Dim descString As String
Dim Altura As Double
Dim ultimaFila As Long
Dim i As Long
Dim ptoDescripcion(0 To 2) As Double
Dim capa As AcadLayer
Dim capaName As String
Dim layerDict As Object
Dim colorIndex As Integer

' Declaración de variables para polilíneas 3D
Dim acad3DPol As Acad3DPolyline
Dim dblCoordinates() As Double
Dim k As Long
Dim layerName As String
Dim currentDescription As String
Dim startRow As Long

' Intentar conectar a AutoCAD
On Error Resume Next
Set AutoCAD = GetObject(, "AutoCAD.Application") ' Intentar conectarse a una instancia existente
On Error GoTo 0

' Si AutoCAD no está abierto, crear una nueva instancia
If AutoCAD Is Nothing Then
Set AutoCAD = CreateObject("AutoCAD.Application") ' Crear una nueva instancia
AutoCAD.Visible = True ' Asegurar que AutoCAD sea visible
End If

' Crear un nuevo dibujo en AutoCAD
AutoCAD.Documents.Add

' Establecer las variables PDMODE y PDsize
AutoCAD.ActiveDocument.SetVariable "PDMODE", Range("H2").Value
AutoCAD.ActiveDocument.SetVariable "PDsize", Range("H3").Value

' Encontrar la última fila con datos en la columna B (Este)
ultimaFila = Cells(Rows.Count, 2).End(xlUp).Row

' Altura del texto
Altura = Range("H11").Value

' Crear un diccionario para rastrear las capas creadas
Set layerDict = CreateObject("Scripting.Dictionary")

' Inicializar el índice de color para las capas
colorIndex = 1

' Bucle para agregar puntos, numeración y descripción
For i = 4 To ultimaFila

' Obtener coordenadas X (Este), Y (Norte), Z (Elevación)
pto(0) = Cells(i, 2).Value ' Este (X)
pto(1) = Cells(i, 3).Value ' Norte (Y)
pto(2) = Cells(i, 4).Value ' Elevación (Z)

' Obtener la descripción de la columna E
descString = Cells(i, 5).Value

' Verificar si ya existe una capa para esta descripción
If Not layerDict.Exists(descString) Then
' Si no existe, crear una nueva capa
Set capa = AutoCAD.ActiveDocument.Layers.Add(descString)
' Asignar un color a la capa (cíclico del 1 al 255)
capa.Color = colorIndex
' Añadir la capa al diccionario
layerDict.Add descString, capa
' Incrementar el índice de color
colorIndex = (colorIndex Mod 255) + 1 ' Evita que el colorIndex supere 255
Else
' Obtener la capa existente
Set capa = layerDict(descString)
End If

' Asignar la capa actual
AutoCAD.ActiveDocument.ActiveLayer = capa

' Insertar el punto en AutoCAD
Set pointObj = AutoCAD.ActiveDocument.ModelSpace.AddPoint(pto)
pointObj.Layer = descString ' Asignar la capa al punto
pointObj.Color = capa.Color ' Color del punto basado en la capa

' Obtener el número de punto de la columna A
textString = Cells(i, 1).Value

' Modificar las coordenadas del texto de numeración
pto(1) = pto(1) + 1 ' Mover en el eje Y

' Agregar el texto del número del punto en AutoCAD
Set textObj = AutoCAD.ActiveDocument.ModelSpace.AddText(textString, pto, Altura)
textObj.Layer = descString ' Asignar la capa
textObj.Color = capa.Color ' Cambiar el color

' Modificar las coordenadas del texto de descripción
ptoDescripcion(0) = pto(0) + 2 ' Mover en el eje X
ptoDescripcion(1) = pto(1) - 2 ' Mover en el eje Y
ptoDescripcion(2) = pto(2) ' Mantener la elevación

' Insertar el texto de la descripción en AutoCAD
Set descTextObj = AutoCAD.ActiveDocument.ModelSpace.AddText(descString, ptoDescripcion, Altura)
descTextObj.Layer = descString ' Asignar la capa
descTextObj.Color = capa.Color ' Cambiar el color

Next i

' Ahora procedemos con las polilíneas 3D

' Inicializar variables para polilíneas
startRow = 4 ' La fila donde comienzan los datos
currentDescription = Cells(startRow, 5).Value ' Primera descripción

' Bucle para dibujar polilíneas 3D por descripción
For i = startRow To ultimaFila
' Si la descripción cambia o se llega al final
If Cells(i, 5).Value <> currentDescription Or i = ultimaFila Then
' Dibujar la polilínea 3D para la descripción actual
Draw3DPolyline AutoCAD, startRow, i - 1, currentDescription

' Actualizar la descripción y el inicio de la nueva polilínea
currentDescription = Cells(i, 5).Value
startRow = i
End If
Next i

' Ajustar el zoom en AutoCAD
AutoCAD.ZoomExtents

MsgBox "Puntos y polilíneas 3D creados correctamente."

End Sub

Sub Draw3DPolyline(ByRef AutoCAD As Object, ByVal startRow As Long, ByVal endRow As Long, ByVal description As String)

' Declaración de variables
Dim acad3DPol As Acad3DPolyline
Dim dblCoordinates() As Double
Dim k As Long
Dim capa As AcadLayer
Dim i As Long
Dim pto(0 To 2) As Double

' Crear un arreglo para almacenar las coordenadas X, Y y Z
ReDim dblCoordinates(3 * (endRow - startRow + 1) - 1)

' Pasar las coordenadas X, Y y Z al arreglo
k = 0
For i = startRow To endRow
dblCoordinates(k) = Cells(i, 2) ' X
dblCoordinates(k + 1) = Cells(i, 3) ' Y
dblCoordinates(k + 2) = Cells(i, 4) ' Z
k = k + 3
Next i

' Crear una capa para la descripción si no existe
On Error Resume Next
Set capa = AutoCAD.ActiveDocument.Layers.Item(description)
If capa Is Nothing Then
Set capa = AutoCAD.ActiveDocument.Layers.Add(description)
End If
On Error GoTo 0

' Cambiar la capa activa
AutoCAD.ActiveDocument.ActiveLayer = capa

' Dibujar la polilínea 3D en AutoCAD
Set acad3DPol = AutoCAD.ActiveDocument.ModelSpace.Add3DPoly(dblCoordinates)
acad3DPol.Layer = description ' Asignar la capa
acad3DPol.Update

End Sub

[-didier- · Accepted solution]

Bonjour @rsalastopografia 

You do not say if the answer is correct for you.
You just type a code (without formatting).
What do we understand ?

It is OK ? Then please “accept solution”.

It is not OK, ask clearly what you need.

Amicalement

[rsalastopografia]

Conseguí lo que buscaba, por eso subí mi codigo VBA. igual gracias por su ayuda, saludos.