Excel VBA to draw network in AutoCAD with inputs from Excel Sheet

[k_l_raghava]

Dear Experts,

Please help me in Providing code for Excel VBA to draw network using the data in Excel Sheet.

I have two named points with X,Y Coordinates - task is to draw a circle with mentioned radius in VBA at the points and insert text at the same point, also a line to be drawn between points (From to To).

Data is in Excel attached, Sample output is attached in AutoCAD file.

Also request for Error Handling (if X,Y in FROM or TO is missing  - VBA should skip the line and continue for the rest - i mean should not stop at that missing line)

I could achieve Circle and Text through VBA but inserting lines through SCR file - i want it in one combined VBA Code.

Thanks in Advance,

Raghavender K

[j_cordero]

HOLA QUE TAL TE ENVIO EL CODIGO Y LOS DOCUMENTOS:

Const TTX As Double = 20


Public Sub NTW()

    Dim AcadApp As AcadApplication
    Set AcadApp = GetObject(, "AutoCAD.Application")
    
    Dim ThisDrawing As AcadDocument
    Set ThisDrawing = AcadApp.ActiveDocument

    Range("A2").Activate
    
    
    Do Until IsEmpty(ActiveCell.Value)
    
'        VALIDACION
        If (IsEmpty(ActiveCell.Offset(0, 1).Value) And IsEmpty(ActiveCell.Offset(0, 2).Value) _
        And IsEmpty(ActiveCell.Offset(0, 3).Value) And IsEmpty(ActiveCell.Offset(0, 4).Value) _
        And IsEmpty(ActiveCell.Offset(0, 5).Value) And IsEmpty(ActiveCell.Offset(0, 6).Value)) = False Then
        
'DESDE

'        CREAR CIRCULO
        ThisWorkbook.CIRCULO ActiveCell.Offset(0, 2).Value, ActiveCell.Offset(0, 3).Value
        
'        CREAR TEXTO
        ThisWorkbook.TXTO ActiveCell.Offset(0, 2).Value, ActiveCell.Offset(0, 3).Value, ActiveCell.Offset(0, 1).Value
        
'HASTA

'        CREAR CIRCULO
        ThisWorkbook.CIRCULO ActiveCell.Offset(0, 5).Value, ActiveCell.Offset(0, 6).Value
        
'        CREAR TEXTO
        ThisWorkbook.TXTO ActiveCell.Offset(0, 5).Value, ActiveCell.Offset(0, 6).Value, ActiveCell.Offset(0, 4).Value
        
'LINEA

'        CREAR LINEA
        ThisWorkbook.LINEA ActiveCell.Offset(0, 2).Value, ActiveCell.Offset(0, 3).Value, ActiveCell.Offset(0, 5).Value, ActiveCell.Offset(0, 6).Value

    ActiveCell.Offset(1, 0).Activate
    End If
    
    Loop
    
End Sub


Public Sub CIRCULO(ByVal centrox As Double, ByVal centroy As Double)

        Dim AcadApp As AcadApplication
        Set AcadApp = GetObject(, "AutoCAD.Application")
        Dim ThisDrawing As AcadDocument
        Set ThisDrawing = AcadApp.ActiveDocument
        Dim circleObj As AcadCircle
        Dim centerPoint(0 To 2) As Double
        Dim radius As Double
        
        centerPoint(0) = centrox: centerPoint(1) = centroy: centerPoint(2) = 0#
        radius = TTX + (TTX * 0.1)
        
        Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)
        

End Sub


Public Sub TXTO(ByVal centrox As Double, ByVal centroy As Double, ByVal texto As String)

        Dim AcadApp As AcadApplication
        Set AcadApp = GetObject(, "AutoCAD.Application")
        Dim ThisDrawing As AcadDocument
        Set ThisDrawing = AcadApp.ActiveDocument

        Dim textObj As AcadText
        Dim textString As String
        Dim insertionPoint(0 To 2) As Double
        Dim height As Double
        
        textString = texto
        insertionPoint(0) = centrox: insertionPoint(1) = centroy: insertionPoint(2) = 0
        height = TTX
        
        Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)
        
        textObj.Alignment = acAlignmentMiddleCenter
        textObj.TextAlignmentPoint = insertionPoint

End Sub

Public Sub LINEA(ByVal SX As Double, ByVal SY As Double, ByVal EX As Double, ByVal EY As Double)

        Dim AcadApp As AcadApplication
        Set AcadApp = GetObject(, "AutoCAD.Application")
        Dim ThisDrawing As AcadDocument
        Set ThisDrawing = AcadApp.ActiveDocument

        Dim lineObj As AcadLine
        Dim startPoint(0 To 2) As Double
        Dim endPoint(0 To 2) As Double
        
        startPoint(0) = SX: startPoint(1) = SY: startPoint(2) = 0#
        endPoint(0) = EX: endPoint(1) = EY: endPoint(2) = 0#
        
        Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

End Sub

SOLO CARGA LA REFERENCIA DE TU AUTOCAD

MODIFIQUE TU TABLA UN POCO, NO PUEDO SUBIR LA HOJA CON LA MACRO, CUAQUIER DUDA CONTACTAME 

SALUDOS

[j_cordero]

TE AGREGO UN VIDEO PARA QUE CARGES LA MACRO

[k_l_raghava]

Dear Mr. j.cordero

thanks for the Code it helped me a lot,

Just one point missing, as i have asked for "error found - skip line and continue", its not happening and if my ID 4 line is missing then entire process is stopping at ID 3 and not considering values in ID 5,6, and hence forth.

Please update the code for the same.

Thank you,

Raghavender.K 

[j_cordero · Accepted solution]

hola te envió el código actualizado

Const TTX As Double = 20


Public Sub NTW()

    Dim AcadApp As AcadApplication
    Set AcadApp = GetObject(, "AutoCAD.Application")
    
    Dim ThisDrawing As AcadDocument
    Set ThisDrawing = AcadApp.ActiveDocument

    Range("A2").Activate
    
    
    Do Until IsEmpty(ActiveCell.Value)
    
'        VALIDACION
        If (IsEmpty(ActiveCell.Offset(0, 1).Value) And IsEmpty(ActiveCell.Offset(0, 2).Value) _
        And IsEmpty(ActiveCell.Offset(0, 3).Value) And IsEmpty(ActiveCell.Offset(0, 4).Value) _
        And IsEmpty(ActiveCell.Offset(0, 5).Value) And IsEmpty(ActiveCell.Offset(0, 6).Value)) = False Then
        
'DESDE

'        CREAR CIRCULO
        ThisWorkbook.CIRCULO ActiveCell.Offset(0, 2).Value, ActiveCell.Offset(0, 3).Value
        
'        CREAR TEXTO
        ThisWorkbook.TXTO ActiveCell.Offset(0, 2).Value, ActiveCell.Offset(0, 3).Value, ActiveCell.Offset(0, 1).Value
        
'HASTA

'        CREAR CIRCULO
        ThisWorkbook.CIRCULO ActiveCell.Offset(0, 5).Value, ActiveCell.Offset(0, 6).Value
        
'        CREAR TEXTO
        ThisWorkbook.TXTO ActiveCell.Offset(0, 5).Value, ActiveCell.Offset(0, 6).Value, ActiveCell.Offset(0, 4).Value
        
'LINEA

'        CREAR LINEA
        ThisWorkbook.LINEA ActiveCell.Offset(0, 2).Value, ActiveCell.Offset(0, 3).Value, ActiveCell.Offset(0, 5).Value, ActiveCell.Offset(0, 6).Value

    ActiveCell.Offset(1, 0).Activate
    End If
    ActiveCell.Offset(1, 0).Activate
    Loop
    
End Sub


Public Sub CIRCULO(ByVal centrox As Double, ByVal centroy As Double)

        Dim AcadApp As AcadApplication
        Set AcadApp = GetObject(, "AutoCAD.Application")
        Dim ThisDrawing As AcadDocument
        Set ThisDrawing = AcadApp.ActiveDocument
        Dim circleObj As AcadCircle
        Dim centerPoint(0 To 2) As Double
        Dim radius As Double
        
        centerPoint(0) = centrox: centerPoint(1) = centroy: centerPoint(2) = 0#
        radius = TTX + (TTX * 0.1)
        
        Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)
        

End Sub


Public Sub TXTO(ByVal centrox As Double, ByVal centroy As Double, ByVal texto As String)

        Dim AcadApp As AcadApplication
        Set AcadApp = GetObject(, "AutoCAD.Application")
        Dim ThisDrawing As AcadDocument
        Set ThisDrawing = AcadApp.ActiveDocument

        Dim textObj As AcadText
        Dim textString As String
        Dim insertionPoint(0 To 2) As Double
        Dim height As Double
        
        textString = texto
        insertionPoint(0) = centrox: insertionPoint(1) = centroy: insertionPoint(2) = 0
        height = TTX
        
        Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)
        
        textObj.Alignment = acAlignmentMiddleCenter
        textObj.TextAlignmentPoint = insertionPoint

End Sub

Public Sub LINEA(ByVal SX As Double, ByVal SY As Double, ByVal EX As Double, ByVal EY As Double)

        Dim AcadApp As AcadApplication
        Set AcadApp = GetObject(, "AutoCAD.Application")
        Dim ThisDrawing As AcadDocument
        Set ThisDrawing = AcadApp.ActiveDocument

        Dim lineObj As AcadLine
        Dim startPoint(0 To 2) As Double
        Dim endPoint(0 To 2) As Double
        
        startPoint(0) = SX: startPoint(1) = SY: startPoint(2) = 0#
        endPoint(0) = EX: endPoint(1) = EY: endPoint(2) = 0#
        
        Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

End Sub

Para que funcione no debe ver ningún espacio en la columna ID, esa columna controla las veces que se ejecuta la macro y al encontrar un espacio se para.

Saludos

[k_l_raghava]

Thank you very much.

I helped me a lot.

Regards,

Raghavender.K