Script to Draw lines between points

[carl3ZPF6]

I have an input file that looks like the following:

I need to draw polylines between the points of the same group, the color of these lines is specified in the Line color column:

1- Blue

2-Red

3-Green

4-Yellow

So the output should look something like this (the numbers correspond to the # column, I have just shown them for reference they don't need to be part of the output):

This is obviously just an example the actual files I will use this script on are like 9,000 pts total. My start so far (not much just determining how many rows and how many groups, my plan was to do something in the second for loop but I was not sure what, perhaps an index match?):

Sub EqptLayout()
Dim acadApp As Object
Dim acadDoc As Object
Dim acadModelSpace As Object
Dim cl As Object
Dim i As Integer
Dim d As Integer
Dim excelApp As Object
Dim excelWorkbook As Object
Dim excelSheet As Object
Dim polyline As Object
Dim bearing As String
Dim foundation As String
Dim splice As String
Dim numRows As Integer
Dim startRow As Integer



Dim dblX As Double
Dim dblY As Double
Dim dblZ As Double
Dim dblRotation As Double


Dim utilObj As Object   ' Late bound object
Set utilObj = ThisDrawing.Utility


' Start AutoCAD (if not already running)
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
On Error GoTo 0

If acadApp Is Nothing Then
    Set acadApp = CreateObject("AutoCAD.Application")
    acadApp.Visible = True
End If

Set acadDoc = acadApp.ActiveDocument
Set acadModelSpace = acadDoc.ModelSpace

Dim msg As String
     i = 0
     d = 0
Dim excelFilePath As String
excelFilePath = "C:\Users...\Test4.xlsx"
Set excelApp = CreateObject("Excel.Application")
Set excelWorkbook = excelApp.Workbooks.Open(excelFilePath)
Set excelSheet = excelWorkbook.Sheets(1)


With excelSheet

    For Each cl In .Range(.[A1].CurrentRegion.Columns(1).Address) 'for each excel row
    i = i + 1
    Next cl
    
   numRows = excelApp.worksheetfunction.Max(.Range("D1:D" & i))
   
   startRow = excelApp.worksheetfunction.Min(.Range("D1:D" & i))
   
   For d = startRow To numRows 'for each group
   
   'perform line drawing here?
   
   Next d
   
End With





End Sub

 Any help is appreciated for how to approach this, thanks. Input file is attached.

[daniel_cadext · Accepted solution]

Is there a HashMap or Dictionary in VBA?  Seems like it would be easier to iterate all the rows and map them by Group#

Then sort the rows in each key by order in group. If needed. This is Python, but I hope it will illustrate my point

import traceback
from pyrx_imp import Rx, Ge, Gi, Db, Ap, Ed
import openpyxl as xl

def PyRxCmd_doit() -> None:
    try:
        # maps
        groups = {}
        clr = {1: 5, 2: 10, 3: 90, 4: 50}

        wb = xl.open("e:/Test4.xlsx")
        ws = wb["Sheet1"]
        
        #assumes sorted order in group
        for row in ws.iter_rows(values_only=True):
            grnum = row[3]
            if grnum in groups:
                groups[grnum].append(row)
            else:
                groups[grnum] = [row]

        lines = []
        for group in groups.values():
            for idx in range(1, len(group)):
                sl = group[idx - 1]
                el = group[idx]
                line = Db.Line(Ge.Point3d(sl[1], sl[2], 0.0), 
                               Ge.Point3d(el[1], el[2], 0.0))
                line.setColorIndex(clr[sl[4]])
                lines.append(line)
        Db.curDb().addToModelspace(lines)

    except Exception as err:
        traceback.print_exception(err)

 

[Ed__Jobe]

Hi Daniel, VBA just has the Dictionary object, Add:key,value.

[carl3ZPF6]

OK, I think I can use a dictionary where the key is the # and the items are an array consisting of group #, color, and order in group

[carl3ZPF6]

On second thought, I am not sure having 9000+ dictionaries is the best solution

[norman.yuan · Accepted solution]

The task you are facing could/should be divided into 2 subtasks: retrieving data from Excel sheet (or whatever data source, for that matter) into a data model; draw the lines using the data model. The "draw" part is really simple, if the data model is correctly create, for example, it is a collection of a sub data model which is a group of points used to create lines.

So, your code should look like

Public Sub DrawLinesFromExternalData(xlsFileName as String)

  Dim groups As LineGroupCollection

  Set groups = ReadDataFromSheet(xlsFileName)

  If groups Is Nothing Then

    MsgBox "Reading data file failed!"

  Else

    DrawGroupLines groups

  End If

End Sub

As you can see, you need to have a data model (class LineGroupCollection), which is a collection of another class LineGroup, which would hold all the points in a group.

Hopefully, you do know how to create class in VBA. To simplify things a bit, you can use an array of LineGroup class, instead of LineGroupCollection class.

Unfortunately, VBA does not provide many built-in data structure. If you do it with .NET API, retrieve the group points and hold them in sortable/groupable data structures are quite easy, but with VBA, you may have to sort/group the data with your own code.

Also, you really should do it from AutoCAD VBA side, rather than from Excel VBA side. Otherwise drawing a few thousands of lines from Excel side would take much longer time than drawing them within AutoCAD VBA.

[carl3ZPF6]

Thanks to @daniel_cadext I was able to get the data reading into a dictionary based on his data structures:

Sub PyRxCmd_doit()
    Dim acadApp As Object
    Dim acadDoc As Object
    Dim acadModelSpace As Object
    Dim groups As Object
    Dim clr As Object
    Dim wb As Object
    Dim ws As Object
    Dim row As Variant
    Dim grnum As Variant
    Dim idx As Integer
    Dim sl As Variant
    Dim el As Variant
    Dim line As AcadLWPolyline
    Dim lines As Object
    
    Dim utilObj As Object   ' Late bound object
Set utilObj = ThisDrawing.Utility
    Dim polyPoints As Variant

' Start AutoCAD (if not already running)
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
On Error GoTo 0

If acadApp Is Nothing Then
    Set acadApp = CreateObject("AutoCAD.Application")
    acadApp.Visible = True
End If
    
    Set groups = CreateObject("Scripting.Dictionary")
    Set clr = CreateObject("Scripting.Dictionary")
    
    clr.Add 1, 5
    clr.Add 2, 10
    clr.Add 3, 90
    clr.Add 4, 50
    
Dim excelFilePath As String
excelFilePath = "C:Test4.xlsx"
Set excelApp = CreateObject("Excel.Application")
Set wb = excelApp.Workbooks.Open(excelFilePath)
Set ws = wb.Sheets(1)
    
    For Each row In ws.UsedRange.Rows
        grnum = row.Cells(1, 4).Value
        If groups.Exists(grnum) Then
            groups(grnum).Add row.Value
        Else
            groups.Add grnum, New Collection
            groups(grnum).Add row.Value
        End If
    Next row
    
    Set lines = CreateObject("Scripting.Dictionary")
    
    For Each group In groups
        For idx = 2 To groups(group).Count
            sl = groups(group)(idx - 1)
            el = groups(group)(idx)
            
            utilObj.CreateTypedArray polyPoints, vbDouble, sl(1, 2), sl(1, 3), el(1, 2), el(1, 3)
            Set line = ThisDrawing.ModelSpace.AddLightWeightPolyline(polyPoints)
            'line.TrueColor = clr(sl(4))
            lines.Add lines.Count + 1, line
        Next idx
    Next group
    
    wb.Close False
End Sub

I am now able to get all lines to plot,  but I had to comment out the color line if not commented out I get "Subscript out of range", any thoughts?

[carl3ZPF6]

Update, got it to work with a case statement:

Sub PyRxCmd_doit()
    Dim acadApp As Object
    Dim acadDoc As Object
    Dim acadModelSpace As Object
    Dim groups As Object
    Dim clr As Object
    Dim wb As Object
    Dim ws As Object
    Dim row As Variant
    Dim grnum As Variant
    Dim idx As Integer
    Dim sl As Variant
    Dim el As Variant
    Dim line As AcadLWPolyline
    Dim lines As Object
    Dim color As AcadAcCmColor
    
    Dim utilObj As Object   ' Late bound object
Set utilObj = ThisDrawing.Utility
    Dim polyPoints As Variant

' Start AutoCAD (if not already running)
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
On Error GoTo 0

If acadApp Is Nothing Then
    Set acadApp = CreateObject("AutoCAD.Application")
    acadApp.Visible = True
End If
    
    Set groups = CreateObject("Scripting.Dictionary")
    Set clr = CreateObject("Scripting.Dictionary")
    
    clr.Add 1, 5
    clr.Add 2, 25
    clr.Add 3, 90
    clr.Add 4, 50
    
Dim excelFilePath As String
excelFilePath = "C:\Users\CarlJackson\Downloads\Test4.xlsx"
Set excelApp = CreateObject("Excel.Application")
Set wb = excelApp.Workbooks.Open(excelFilePath)
Set ws = wb.Sheets(1)
    
    For Each row In ws.UsedRange.Rows
        grnum = row.Cells(1, 4).Value
        If groups.Exists(grnum) Then
            groups(grnum).Add row.Value
        Else
            groups.Add grnum, New Collection
            groups(grnum).Add row.Value
        End If
    Next row
    
    Set lines = CreateObject("Scripting.Dictionary")
    
    For Each group In groups
        For idx = 2 To groups(group).Count
            sl = groups(group)(idx - 1)
            el = groups(group)(idx)
            
            utilObj.CreateTypedArray polyPoints, vbDouble, sl(1, 2), sl(1, 3), el(1, 2), el(1, 3)
            Set line = ThisDrawing.ModelSpace.AddLightWeightPolyline(polyPoints)
            'Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor." & acVer)
            'color.SetRGB 255, 255, 0
            Set color = line.TrueColor
            Select Case sl(1, 5)
            
            Case 1
            color.SetRGB 0, 0, 255
            Case 2
            color.SetRGB 255, 0, 0
            Case 3
            color.SetRGB 0, 255, 0
            Case 4
            color.SetRGB 0, 255, 255
            
            
            End Select
            
            With line
                      .Closed = False
                        .ConstantWidth = 10
                         .Layer = "0"
                          .TrueColor = color
            End With
            lines.Add lines.Count + 1, line
        Next idx
    Next group
    
    wb.Close False
End Sub

[daniel_cadext]

Awesome! BTY, 9000 entries is nothing on modern computers, even millions is no problem

The “Subscript out of range” could have been you hitting the ‘NaN’, I did that while penning the python sample.

Since you are using RGB in a case, you can nix the clr dictionary, you probably don’t need the ‘lines’ dictionary either, at least I don’t see a need for it. If you need access to the lines later, just store the objectids or handles in an array

[carl3ZPF6]

Trying to add column headers into the input document, I changed this line

 grnum = row.Cells(1, 4).Value

to

grnum = row.Cells(2, 4).Value

buy still getting error on  :

utilObj.CreateTypedArray polyPoints, vbDouble, sl(1, 2), sl(1, 3), el(1, 2), el(1, 3)

looks like s1 is picking up the header names, how can I prevent this?

[carl3ZPF6]

Disregard, I just needed to change the first for loop starting at 2.

  For i = 2 To ws.UsedRange.Rows.Count ' Start from the second row to ignore headers
        Set row = ws.Rows(i)
        grnum = row.Cells(1, 4).Value '4th row is group/ row #
        If groups.Exists(grnum) Then
            groups(grnum).Add row.Value
        Else
            groups.Add grnum, New Collection
            groups(grnum).Add row.Value
        End If
    Next i