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.
Solved! Go to Solution.
Solved by norman.yuan. Go to Solution.
Solved by daniel_cadext. Go to 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)
Hi Daniel, VBA just has the Dictionary object, Add:key,value.
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
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.
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?
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
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
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?
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
Can't find what you're looking for? Ask the community or share your knowledge.