topic Re: Script to Draw lines between points in VBA Forum

Script to Draw lines between points

carl3ZPF6 — Wed, 22 May 2024 16:00:28 GMT

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.

Re: Script to Draw lines between points

daniel_cadext — Thu, 23 May 2024 01:57:22 GMT

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)

Re: Script to Draw lines between points

Ed__Jobe — Thu, 23 May 2024 15:00:03 GMT

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

Re: Script to Draw lines between points

carl3ZPF6 — Thu, 23 May 2024 15:29:34 GMT

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

Re: Script to Draw lines between points

carl3ZPF6 — Thu, 23 May 2024 15:38:44 GMT

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

Re: Script to Draw lines between points

norman.yuan — Thu, 23 May 2024 19:25:33 GMT

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.

Re: Script to Draw lines between points

carl3ZPF6 — Thu, 23 May 2024 20:17:25 GMT

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?

Re: Script to Draw lines between points

carl3ZPF6 — Thu, 23 May 2024 20:51:22 GMT

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

Re: Script to Draw lines between points

daniel_cadext — Thu, 23 May 2024 23:07:39 GMT

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

Re: Script to Draw lines between points

carl3ZPF6 — Fri, 24 May 2024 17:25:29 GMT

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

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

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?

Re: Script to Draw lines between points

carl3ZPF6 — Fri, 24 May 2024 17:38:23 GMT

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