A Table is an Array

Autocad tables and VBA arrays have the same structure. You can make a sub procedure that takes an array passed as argument that makes an autocad table. The table sub can read the array and determine how many rows and columns it contains. The array is made in any sub specific to the task and separate from making or loading the table. The program flow can make just the data table without Title or Headers and add those later from other data.

The simplest way to make an array is with the array function.

ar_labels = Array(“MKNO”, “QTY”, “LENGTH”, “WIDTH”, “DESC”)
‘ ar_labels is single dimension 0 to cnt – 1

Debug.Print LBound(ar_labels) ‘get 0
Debug.Print UBound(ar_labels) ‘get 4

The autocad method to Addtable requires 5 parameters.

RetVal = object.AddTable(InsertionPoint, NumRows, NumColumns, RowHeight, ColWidth

Rowheight and colwidth is up to you. To keep it simple use what generic table Standard supplies at first. numrows and numcolumns come from looking at the array upper and lower index.

To make a table display a single dimension array in a single row.

Call make_1D_table(ar_labels)

Sub make_1D_table(ar As Variant)
' ar is single dimension 0 to cnt - 1
' tbl is public as AcadTable
' RowHeight and ColWidth are public as double
' location pt0 would be public too as soon as needed

     Dim pt0(0 To 2) As Double '000
     Dim i As Integer, j As Integer
     Dim rowcount As Integer, colcount As Integer
       
    rowcount = 1
    colcount = UBound(ar) - LBound(ar) + 1
  
    'create the table sized for the array
    Set tbl = acadDoc.ModelSpace.AddTable(pt0, rowcount, colcount, RowHeight, ColWidth)
 
      'object.UnmergeCells minRow, maxRow, minCol, maxCol
    tbl.UnmergeCells 0, 0, 0, 0
    tbl.TitleSuppressed = True
     tbl.HeaderSuppressed = True
     
 'right here is where table format has to occur before data is entered

'zero base array fits with autocad zero base table
 For j = 0 To colcount - 1
  If Not IsEmpty(ar(j)) And (ar(j)) <> "" Then
     tbl.SetText 0, j, ar(j)
  End If
 Next j
 
tbl.Update
End Sub


For our main 2 dimensional data table, we do the same thing but get table dims first. One issue that comes up on adding tables is the behavior of title and header rows. Another issue is when text overflows a single line and causes the row width to pop down. It pops down automatically, but not up. The cell width should be set before the data is loaded. This table sub is set up to only make data rows. The way it works though, the table is made with title and header rows, I dont think there is any way to stop that, and then the table object methods are used to modify the table. You might want to make the textsize of the title row the same as data in the table style manager, if you are using the Standard style. Otherwise depending on the data loaded, you may get a top row with a different height.

After we get the table made, in real life we want to have our own tablestyle and probably do some formatting of the text before it is written to screen. I am just showing the data side here.


Public ar_labels As Variant
Public ar_dims As Variant
Public tbl As AcadTable
Public RowHeight As Double
Public ColWidth As Double
Public hexstart As String

Sub make_2D_table(ar As Variant)
'table is two-dimensional and any-base
' ar(rows,columns)
'  tbl is public As AcadTable
'  RowHeight and ColWidth are public as Double
'  pt0 could be public when needed
  
    Dim i As Integer, j As Integer
    Dim rowcount As Integer, colcount As Integer
    Dim rowLbound As Integer, colLbound As Integer
    Dim rowUbound As Integer, colUbound As Integer
     
    Dim pt0(0 To 2) As Double
        
    rowLbound = LBound(ar, 1)
    rowUbound = UBound(ar, 1)
    colLbound = LBound(ar, 2)
    colUbound = UBound(ar, 2)
    rowcount = rowUbound - rowLbound + 1
    colcount = colUbound - colLbound + 1
        
    Set tbl = acadDoc.ModelSpace.AddTable(pt0, rowcount, colcount, RowHeight, ColWidth)
    'the tablestyle does not dictate the use of a title or header
    'at this point the table has a title and header
    'whether they are merged on creation is per style method EnableMergeAll "Title", True
    'if the title row textsize in standard is larger than data textsize
    'the title row cell height may be larger than data rows.
    
   '     data rows only option
     tbl.UnmergeCells 0, 0, 0, 0
     tbl.TitleSuppressed = True
     tbl.HeaderSuppressed = True

 'right here is where table format has to occur before data is entered
 'using the methods of tbl object we could hand off to a sub here
 
       For i = rowLbound To rowUbound
         For j = colLbound To colUbound
             If Not IsEmpty(ar(i, j)) Then
         tbl.SetText i - rowLbound, j - colLbound, ar(i, j)
             End If
         Next j
       Next i
     
 'a sub to add title or header can run next
 'tbl.InsertRows 0, RowHeight, 1
  
    acadApp.Update
End Sub

Here is a sub to make a multiplication table array with 12X12 hard wired in.
You can experiment with different numbers and see if the table sub handles it.
There is no title or header row.


Sub test_mult_tbl()
'only job is to fill array ar_dims global
 Dim rows As Integer, i As Integer
 Dim columns As Integer, j As Integer
 
    rows = 12
    columns = 12
    ReDim ar_dims(1 To rows, 1 To columns)
     
    For i = 1 To rows
       For j = 1 To columns
           ar_dims(i, j) = i * j
       Next j
    Next i
End Sub


Sub test_226()
    Call Connect_Acad
    Call test_mult_tbl
        RowHeight = 0.125
        ColWidth = 0.625
    Call make_2D_table(ar_dims)
End Sub

You can make a font table using ascii codes. Fonts use hex codes which are base 16. A 16X16 table displays 256 characters. After we make the data table we will add a title row and put the name of the font in it.


Sub test_ascii_table()
  ' only job is to make array
  ' 0 to 255 ascii table 16^2
Dim rows As Integer, i As Integer
Dim columns As Integer, j As Integer
     
    rows = 16
    columns = 16
    ReDim ar_dims(1 To rows, 1 To columns)
     
    For i = 1 To rows
        For j = 1 To columns
            'ar_dims(i, j) = CInt(((i - 1) * 16 + (j - 1)))
            ar_dims(i, j) = Chr(((i - 1) * 16 + (j - 1)))
        Next j
    Next i

End Sub

It gets called as before but we are adding a title row after the data is written.
Tablestyles have textstyles, so I am creating a new tablestyle each time using the current font name, and putting that font style name into the tablestyle to be used.


Sub test_228()
Call Connect_Acad

'call style before table call
    Call mk_tbl_styl(acadDoc.GetVariable("textstyle"))

'makes ar_dims
    Call test_ascii_table

    RowHeight = 0.125
    ColWidth = 0.375

    Call make_2D_table(ar_dims)

 'add a title row to top after plain table made
   tbl.InsertRows 0, RowHeight, 1
   tbl.MergeCells 0, 0, 0, tbl.columns - 1
   tbl.TitleSuppressed = False
   tbl.SetText 0, 0, acadDoc.GetVariable("textstyle")
 
End Sub


Unicode is a long extension of ascii. There are many sections. You have to look up the hex code of the section you want to display.


Sub test_unicode()
'only job is to make array of unicode block numbers
'hexstart public string

 Dim numstart As Double
 Dim rows As Integer, i As Integer
 Dim columns As Integer, j As Integer
     
    rows = 16
    columns = 16
    ReDim ar_dims(1 To rows, 1 To columns)
    numstart = HexToDec(hexstart)
 
    For i = 1 To rows
        For j = 1 To columns
            ar_dims(i, j) = DecToHex(numstart + (i - 1) * 16 + (j - 1))
            ar_dims(i, j) = "\U+" & ar_dims(i, j)
        Next j
    Next i
End Sub

Sub test_229()
Call Connect_Acad
Call new_textstyle("Cambria Math", "Cambria Math")

hexstart = "2200"
Call test_unicode
   
   RowHeight = 0.125
   ColWidth = 0.5

Call make_2D_table(ar_dims)
   
   'add title row with caption hexnum and textstyle name
   tbl.InsertRows 0, RowHeight, 1
   tbl.MergeCells 0, 0, 0, tbl.columns - 1
   tbl.TitleSuppressed = False
   tbl.SetText 0, 0, "&H" &  hexstart & " " & acadDoc.GetVariable("textstyle")
 
End Sub


Header rows can be inserted just like Title rows. The header data can come from the Array command. The sub is similar to the 1D sub but even simpler.

Advertisements

Euclid Book 1 Proposition 3

Proposition 3 looks simple, but it uses Proposition 2 which uses Proposition 1. Prop 3 is in turn used by many other Propositions through the entire work.

For debugging it was handy to have a consistent not random pair of given lines, so I made a definite parameter start procedure, selected to look similar to the traditional start points.

Sub prime_pr3()
'given two unequal lines AB and GH
Connect_Acad

Dim ptA(0 To 2) As Double
Dim ptB(0 To 2) As Double
Dim ptG(0 To 2) As Double
Dim ptH(0 To 2) As Double

Dim Ax As Double, Ay As Double
Dim Bx As Double, By As Double
Dim Gx As Double, Gy As Double
Dim Hx As Double, Hy As Double

Ax = rnddbl(0, 5)
Ay = rnddbl(0, 5)
Bx = rnddbl(15, 25)
By = rnddbl(0, 10)
Hx = rnddbl(-5, 0)
Hy = rnddbl(12, 18)
Gx = rnddbl(5, 5)
Gy = rnddbl(12, 18)

Call pt(ptA, Ax, Ay, 0)
Call pt(ptB, Bx, By, 0)
Call pt(ptG, Gx, Gy, 0)
Call pt(ptH, Hx, Hy, 0)

Call pr3_sub(ptA, ptB, ptG, ptH)
    
    acadApp.Update
End Sub


Sub pump_pr3()
'hardwiring two unequal lines AB and GH
Connect_Acad

Dim ptA(0 To 2) As Double
Dim ptB(0 To 2) As Double
Dim ptG(0 To 2) As Double
Dim ptH(0 To 2) As Double

Call pt(ptA, 1, 1, 0)
Call pt(ptB, 10, 2, 0)
Call pt(ptG, 3, 8, 0)
Call pt(ptH, -3, 9, 0)

Call pr3_sub(ptA, ptB, ptG, ptH)
    
    acadApp.Update
End Sub


Sub pr3_sub(ptA() As Double, ptB() As Double, ptG() As Double, ptH() As Double)

Dim lineAB As AcadLine, lineGH As AcadLine
Dim lineAH As AcadLine
Dim lineAE As AcadLine, lineEB As AcadLine
Dim lineAD As AcadLine
Dim circF As AcadCircle

Dim r As Double
Dim intpts As Variant

Dim ptD(0 To 2) As Double
Dim ptE(0 To 2) As Double

Set lineAB = acadDoc.ModelSpace.AddLine(ptA, ptB)
Set lineGH = acadDoc.ModelSpace.AddLine(ptG, ptH)

'i copied sub for prop2 and only added object deletes
'at the bottom otherwise this is same as pr2
'pr2 calls its own pr1
Call pr3_pr2_sub(ptA, ptG, ptH)

 'vertex found
ptD(0) = ptG1(0)
ptD(1) = ptG1(1)
ptD(2) = ptG1(2)

r = distance(ptA, ptD)
Set circF = acadDoc.ModelSpace.AddCircle(ptA, r)

intpts = lineAB.IntersectWith(circF, acExtendNone)
Call intpts_eval(intpts)

'should only be one
ptE(0) = intpts(0)
ptE(1) = intpts(1)
ptE(2) = intpts(2)

lineAB.Delete
'circF.Delete

Set lineAE = acadDoc.ModelSpace.AddLine(ptA, ptE)
Set lineEB = acadDoc.ModelSpace.AddLine(ptE, ptB)

'labels
Dim th As Double
th = 1#

Call txt_h("A", ptA, th)
Call txt_h("B", ptB, th)
Call txt_h("D", ptD, th)
Call txt_h("E", ptE, th)

End Sub

If Euclid had Autocad

The 2300 year old geometry primer begins with definitions for point, line and plane surface establishing these concepts which will be used virtually unchanged even in modern cad applications. A point has no parts, it says. Later geometers will add it only has position but no dimension. A line has only length, no width, only one dimension. A plane surface has both length and width, two dimensions. 17th century mathematicians added XYZ variables to locate position. Euclid constructed, stated (“I say that…”), and proved elementary facts of geometry by starting with the most basic usable definitions and with virtual or real tools of straightedge and compass, that only allowed lines and circles to be constructed, made a textbook of geometry theorems that all depend on previous constructions for the proof of their canonic accuracy. His very first theorem constructs an equilateral triangle, a triangle with all sides and all angles equal, from a single random line.

Euclid has been criticized by moderns because he included no previous definition, postulate or axiom that two circles overlapping intersect in a single point. I thought finding that intersection point would be the hardest part of programming it, but there is a dedicated method, Intersectwith, for nearly every autocad object which returns a single dimension array of x, y and z values for all intersections. Here I just choose the first one. I use a random number generator to create the seed line.


Sub prime_pr1()
'given lineAB call proposition1
Connect_Acad

Dim ptA(0 To 2) As Double
Dim ptB(0 To 2) As Double
Dim Ax As Double, Ay As Double
Dim Bx As Double, By As Double

Ax = rnddbl(0, 10)
Ay = rnddbl(0, 10)
Bx = rnddbl(11, 20)
By = rnddbl(0, 10)

Call pt(ptA, Ax, Ay, 0)
Call pt(ptB, Bx, By, 0)
   
   Call pr1(ptA, ptB)
acadApp.Update
End Sub


Sub pr1(ptA() As Double, ptB() As Double)
Dim lineAB As AcadLine, lineAC As AcadLine, lineBC As AcadLine
Dim circD As AcadCircle, circE As AcadCircle
Dim ptC(0 To 2) As Double

Dim r As Double
Dim intpts As Variant

Set lineAB = acadDoc.ModelSpace.AddLine(ptA, ptB)

r = distance(ptA, ptB)
Set circD = acadDoc.ModelSpace.AddCircle(ptA, r)

r = distance(ptB, ptA)
Set circE = acadDoc.ModelSpace.AddCircle(ptB, r)

intpts = circD.IntersectWith(circE, acExtendNone)
Call intpts_eval(intpts)

'going to take positive y value
'keeps traditional illustrations upright
    If ptG1(1) > ptG2(1) Then
ptC(0) = ptG1(0)
ptC(1) = ptG1(1)
ptC(2) = ptG1(2)
    Else
ptC(0) = ptG2(0)
ptC(1) = ptG2(1)
ptC(2) = ptG2(2)
    End If

Set lineAC = acadDoc.ModelSpace.AddLine(ptA, ptC)
Set lineBC = acadDoc.ModelSpace.AddLine(ptB, ptC)

End Sub



helper functions


Option Explicit

Public num_int_pts As Integer

Public ptG1(0 To 2) As Double
Public ptG2(0 To 2) As Double

'to evaluate the output array of the Intersectwith method
'loads up to two points in a global variable
'the calling program has to decide which one to use
'the core loop here taken directly out of autocad vba help for Intersectwith method
Sub intpts_eval(intpts As Variant)
 Dim i As Integer, j As Integer, k As Integer
    Dim str As String

If VarType(intpts) <> vbEmpty Then
        For i = LBound(intpts) To UBound(intpts)
            str = "Intersection Point[" & k & "] is: " & intpts(j) & "," & intpts(j + 1) & "," & intpts(j + 2)
            Debug.Print str
            str = ""
            i = i + 2
            j = j + 3
            k = k + 1
        Next
    End If
    
    Debug.Print LBound(intpts)
    Debug.Print UBound(intpts)
    
  'global var
  num_int_pts = k
  
  Select Case k
  Case Is = 0
  ptG1(0) = 0: ptG1(1) = 0: ptG1(2) = 0
  ptG2(0) = 0: ptG2(1) = 0: ptG2(2) = 0
  
  Case Is = 1
  Call pt(ptG1, (intpts(0)), (intpts(1)), (intpts(2)))
  ptG2(0) = 0: ptG2(1) = 0: ptG2(2) = 0
    
  Case Is = 2
  Call pt(ptG1, (intpts(0)), (intpts(1)), (intpts(2)))
  Call pt(ptG2, (intpts(3)), (intpts(4)), (intpts(5)))
 
  Case Is > 2
    MsgBox "thats a lot of points"
 End Select
End Sub


Sub pt(ByRef ptn() As Double, x As Double, y As Double, z As Double)
ptn(0) = x: ptn(1) = y: ptn(2) = z
End Sub

Function rnddbl(upr As Double, lwr As Double) As Double
Randomize
rnddbl = CDbl((upr - lwr + 1) * Rnd + lwr)
End Function

' straight out of autocad vba help
' Calculate distance between two points
Function distance(sp As Variant, ep As Variant) As Double
  Dim x As Double
  Dim y As Double
  Dim z As Double
  x = sp(0) - ep(0)
  y = sp(1) - ep(1)
  z = sp(2) - ep(2)

  distance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function

DimStyles and TextStyles

Dimstyles are a collection. Each dimstyle object is itself a collection of 78 variables (at least) that are not visible in VBA. They can be set through the setvariable method of the activedocument, but I dont think there is any way to survey for them except through the autocad interface. Typing -Dimstyle at the command line (with a dash) brings up the command line version with a Variables option. Type V, then type STANDARD to get a nice screen list of every variable and its value in the STANDARD style. I cut and pasted this to a text editor capable of column mode, then eventually pasted it into a visual basic module for the purpose of using it to make a new dimension style. It looked better in the text editor. this is HTML which eliminates extra spaces. So you get a screenshot. This is Autocad 2018.

The STANDARD dimstyle is the default. Creating a new dimstyle in VBA with AcadDoc.DimStyles.Add(“my_new_name”) creates a copy of the intrinsic standard, the same settings STANDARD is made from. The settings desired are then made by changing the current variables in the activedrawing, then using Dimstyle.CopyFrom method to load all current dim variables into the Dimstyle object. So that means we dont have to rewrite all these values. We create a new clean style, its our only option, we run a list of AcadDoc.Setvariable “DIMXXX” changes we want to use, and then we run the CopyFrom method.

I looked at some Dimstyles I use and came up with a list to vary the standard to an Inch style i use, then having worked out those variables, i saw that my feet style only changed 3 of the Inch variables. So these can be run incrementally. If i want Feet, i run Inches then Feet over the top of it. Similarly Decimal only changes 2 variables from Feet.

The dimension textstyle and dimscale used vary as needed. We want to be able to change them at will.

here are the “scripts” to change variables, with textstyle and dimscale removed. Everything not shown will be the same as the Standard. The details are subject to change.

 Sub dim_inch()
 '  acadDoc.setvariable "DIMSCALE", 1#                    '  Overall scale factor"
 '  acadDoc.setvariable "DIMTXSTY", "Standard"            '  Text style"
  acadDoc.setvariable "DIMLUNIT", 5                      '  Linear unit format"
  acadDoc.setvariable "DIMFRAC", 1                       '  Fraction format"
 
  acadDoc.setvariable "DIMTXT", 0.125                    '  Text height"
  acadDoc.setvariable "DIMASZ", 0.09375                  '  Arrow size"
  
  acadDoc.setvariable "DIMCLRT", 7                       '  Dimension text color

  acadDoc.setvariable "DIMTAD", 1                        '  Place text above the dimension line"
  acadDoc.setvariable "DIMTOH", 0                        '  Text outside horizontal"
  acadDoc.setvariable "DIMTIH", 0                        '  Text inside extensions is horizontal"
  acadDoc.setvariable "DIMTOFL", 1                       '  Force line inside extension lines"
  acadDoc.setvariable "DIMTIX", 1                        '  Place text inside extensions"
 
  acadDoc.setvariable "DIMTMOVE", 2                      '  Text movement - dont move the line"
  acadDoc.setvariable "DIMEXE", 0.0625                   '  Extension above dimension line"
 End Sub
 
 
 Sub dim_feet()
  acadDoc.setvariable "DIMLUNIT", 4                      '  Linear unit format"
  acadDoc.setvariable "DIMFRAC", 2                       '  Fraction format"
  acadDoc.setvariable "DIMZIN", 3                       '  Zero suppression"
 End Sub
 
 
 Sub dim_decimal()
  acadDoc.setvariable "DIMLUNIT", 2                      '  Linear unit format"
  acadDoc.setvariable "DIMADEC", 1                      '  Angular decimal places
 End Sub

For this approach, i want the dimstyle to use whatever textstyle is current. I want to tell it the dimscale and the textstyle. Textstyles are made very similar to Dimstyles. They are a collection, a new name is added that has default settings, the settings are changed. They dont have many settings. When programming you mostly need to keep the user supplied name mentally separate from the official system font name. usually they are the same or similar, but the font system name has to be given exactly. its helpful to look at the GetFont method first to see what the values are that autocad returns for the settings of textstyles set up through the interface Styles dialog.

Sub getfont()
Connect_Acad
Dim styles As AcadTextStyles
Dim style As AcadTextStyle
Set styles = acadDoc.TextStyles

Dim strtypeface As String
Dim bold As Boolean, italic As Boolean
Dim lngchar As Long, lngpitch As Long

For Each style In styles
    style.getfont strtypeface, bold, italic, lngchar, lngpitch

    Debug.Print style.Name    'user supplied name in the list box of the style dialog
    Debug.Print style.fontFile  'actual file name not shown in style dialog
    Debug.Print strtypeface     'font name dropdown box in style dialog
    Debug.Print bold
    Debug.Print italic
    Debug.Print lngchar
    Debug.Print lngpitch
    Debug.Print
Next
End Sub

Once that is clear, you can send the same values you see in the Debug (Immediate) window. TextStyles.Add(“usernamehere”) will add any name you choose, but the typeface name must be as you see in the Autocad Style Dialog Font Name pulldown box.

Sub new_textstyle(str_stylename As String, str_typeface As String)

    Dim bold As Boolean, italic As Boolean
    Dim lngchar As Long, lngpitch As Long
    lngchar = 0
    lngpitch = 34 'i am sure this is not meaningless but this is typ(swiss 32 variable 2)
    bold = False
    italic = False
     
    Dim TextStyles As AcadTextStyles
    Dim curStyle As AcadTextStyle
    Dim newStyle As AcadTextStyle

    Set curStyle = acadDoc.ActiveTextStyle
    Set TextStyles = acadDoc.TextStyles
    
    Set newStyle = TextStyles.Add(str_stylename)
    acadDoc.ActiveTextStyle = newStyle
 
 'new style is added with no font information
 'autocad assigns defaults similar or same as standard
 
    newStyle.SetFont str_typeface, bold, italic, lngchar, lngpitch
    
    'sometimes i get a transient new style at this point
    'eliminated by the next new style unless i create actual text
End Sub

now we need the dimstyle creation that accepts parameters for the type (Inch, Feet, Decimal) and scale, using the current textstyle.
I am going to name the dimstyle according to the parameters used to make it.

Sub new_dimstyle(strname As String, strtype As String, dm As Integer)
    
    Dim style As AcadDimStyle
    Dim strdimstyle As String
    Dim strtextstyle As String
        strtextstyle = acadDoc.GetVariable("textstyle")
    
    strdimstyle = strname & "_" & strtype & "_" & dm
        
     Set style = acadDoc.DimStyles.Add(strdimstyle)
     acadDoc.ActiveDimStyle = style
     
      Select Case strtype
        Case "Inch"
        Call dim_inch
        
        Case "Feet"
        Call dim_inch
        Call dim_feet
        
        Case "Decimal"
        Call dim_inch
        Call dim_feet
        Call dim_decimal
      End Select

     acadDoc.setvariable "DIMTXSTY", strtextstyle
     acadDoc.setvariable "DIMSCALE", dm
    
    style.CopyFrom acadDoc  'the basic method for changing style contents

End Sub

and finally we can call it various ways.

Sub test_dim()
Call Connect_Acad

Call new_textstyle("Arial Narrow", "Arial Narrow")
Call new_dimstyle("ArialN", "Inch", 24)

Call new_textstyle("Technic", "Technic")
Call new_dimstyle("Technic", "Feet", 24)

Call new_textstyle("Courier", "Courier New")
Call new_dimstyle("Courier", "Decimal", 24)

End Sub

Using Move, Copy with AcadSelectionSet

Selection Sets in Autocad VBA do not contain methods to Move, Copy, Rotate, Scale, Mirror etc. The programmer has to make a For-Each loop to iterate through the Selection Set and apply the method to each individual entity one at a time. There are quite a few steps between making the selection set, populating it, then looping through its members and actually doing something to them. Breaking down these steps into small re-usable sub-procedures is the way to go.

Other than how to use them, Selection Sets have pretty good documentation not too hard to understand. The first sub-procedure makes a new clean Selection Set in the drawing. If it already exists it deletes it. Its called with a parameter name.

Sub addss(strname As String)
'adds a clean selection set
    Dim sset As AcadSelectionSet
    On Error Resume Next
    
    Set sset = acadDoc.SelectionSets.Item(strname)
    sset.Delete
    Set sset = acadDoc.SelectionSets.Add(strname)
    
    If sset Is Nothing Then
    MsgBox "unable to add " & strname & " selection set"
    End If
End Sub

In a recent program I made two kinds of selection, ALL and Window, so I made two function procedures to handle this task and return an AcadSelectionSet object. These functions call addss above. The way these work are documented and easily found with VBA ACADSelectionSets. Think of this as the second layer of abstraction, a function to make and return a set according to your selection method.

Function sset_all() As AcadSelectionSet
'returns a selection set ALL
    addss ("All_Entities")
    Set sset_all = acadDoc.SelectionSets.Item("All_Entities")
     sset_all.Select acSelectionSetAll
End Function

 Function sset_win(x1 As Double, y1 As Double, x2 As Double, y2 As Double) As AcadSelectionSet
 'returns a selection set with window selection
    Dim pt1(0 To 2) As Double
    Dim pt2(0 To 2) As Double
    
    Call initpt(pt1, x1, y1, 0)
    Call initpt(pt2, x2, y2, 0)
    
    'items not visible do not select
    acadApp.Update
    acadApp.ZoomAll

    addss ("Win_Entities")
    Set sset_win = acadDoc.SelectionSets.Item("Win_Entities")
    sset_win.Select acSelectionSetWindow, pt1, pt2
End Function

Sub initpt(ByRef ptn() As Double, val1 As Double, val2 As Double, val3 As Double)
ptn(0) = val1: ptn(1) = val2: ptn(2) = val3
End Sub

initpt is a little helper I made. You don’t need the ByRef keyword, I put it in there to remind that arrays always pass by reference. It would not work otherwise.

Now we have, when properly called, a selection set of our choosing. We want to make sub-procedures for MOVE, COPY, ROTATE, MIRROR and SCALE which accept a selection set as an argument and whatever other basic parameters required, such as a displacement for MOVE. This is the third level of abstraction. We are calling these methods with a selection set previously selected by whatever method.

Erase is the simplest case. it doesnt require a loop.

Sub erase_ss(sset As AcadSelectionSet)
    sset.Erase 'erases the autocad entities in the drawing
    sset.Delete 'deletes the selection set
    Set sset = Nothing
        'call by reference will set to nothing in calling program
End Sub

now finally here is the code to MOVE a selection set using a loop to go thru the set for each item. It takes the set itself as argument and the displacement in x and y. You can select items with either of the subs above by window or all or your program with Crossing or Filters. Deleting the selection set at the end of the routine is optional and may not always be desired, say if you wanted to move and rotate.

Sub move_ss(sset As AcadSelectionSet, x1 As Double, y1 As Double)
'x1 y1 is the displacement
    Dim objent As AcadEntity
    Dim pt0(0 To 2) As Double
    Dim pt1(0 To 2) As Double
    
    Call initpt(pt0, 0, 0, 0)
    Call initpt(pt1, x1, y1, 0)
    
    If 0 <> sset.Count Then
    For Each objent In sset
    objent.Move pt0, pt1
    Next
    End If

    sset.Delete 'deletes the selection set
    Set sset = Nothing
        'call by reference will set to nothing in calling program
End Sub

At this point these sub-procedures still do not change per program requirements. They are basic tools.
Here are mirror and scale (I have not needed COPY yet).

Sub mirror_ss(sset As AcadSelectionSet, pt1() As Double, pt2() As Double)
  'deletes old copy, pt1 pt2 are axis
    Dim objent As AcadEntity
    Dim objent_mirrored As AcadEntity

   If 0 <> sset.Count Then
    For Each objent In sset
    Set objent_mirrored = objent.Mirror(pt1, pt2)
    objent.Delete
    Next
  End If
         sset.Delete
    Set sset = Nothing
 End Sub
 
 Sub scale_ss(sset As AcadSelectionSet, x1 As Double, y1 As Double, sc As Integer)
'x1 y1 is the scale from point, sc is the scale factor
    Dim objent As AcadEntity
    Dim pt0(0 To 2) As Double
    Call initpt(pt0, x1, y1, 0)

    If 0 <> sset.Count Then
    For Each objent In sset
    objent.ScaleEntity pt0, sc
    Next
    End If
    
    acadApp.Update
    acadApp.ZoomAll

    sset.Delete 'deletes the selection set
    Set sset = Nothing
        'call by reference will set to nothing in calling program
End Sub

Now to some extent, we have hidden the loops, we don’t have to duplicate them, and we can call them with simple programs. Here are some upper level calling programs. You will need to write your own according to the method and selection you want to use.

Sub erase_all()
    Dim sset As AcadSelectionSet
    Set sset = sset_all
    Call erase_ss(sset)
End Sub

Sub move_all(x1 As Double, y1 As Double)
    Dim sset As AcadSelectionSet
    Set sset = sset_all
    Call move_ss(sset, x1, y1)
End Sub

Sub scale_w(x1 As Double, y1 As Double, x2 As Double, y2 As Double, sc As Integer)
 'scales from pt 0,0
    Dim sset As AcadSelectionSet
    Set sset = sset_win(x1, y1, x2, y2)
    Call scale_ss(sset, 0, 0, sc)
 End Sub

Sub mirror_all(pt1() As Double, pt2() As Double)
    Dim sset As AcadSelectionSet
    Set sset = sset_all
    Call mirror_ss(sset, pt1, pt2)
 End Sub

those get called rather simply by your top level, where you can see what you are doing without having to dive in to the details.

Call erase_all
Call move_all (0,20)
Call scale_w(-1, -1, 12, 9.5, sc)
Call mirror_all(vt1, vt4)

when you draw with xy data starting at the origin, this is how you move and position the piece onto your drawing assembly or border.

Polyline SetBulge Arc factor

The Autocad VBA object AcadLWPolyline is made in straight line segments with AddLightWeightPolyline method using an array of coordinates. The LWPolyline object returned has a SetBulge method to change a straight line segment to an arc. Setbulge takes two parameters, the lower numbered index of the vertex that begins the segment, and a Bulge value. the Bulge value is explained thusly –

“The bulge is the tangent of 1/4 of the included angle for the arc between the selected vertex and the next vertex in the polyline’s vertex list. A negative bulge value indicates that the arc goes clockwise from the selected vertex to the next vertex. A bulge of 0 indicates a straight segment, and a bulge of 1 is a semicircle.”
https://knowledge.autodesk.com/search-result/caas/CloudHelp/cloudhelp/2017/ENU/AutoCAD-ActiveX/files/GUID-E1CE125E-AB3A-4645-B548-E43200064F9C-htm.html

The arc no matter what curvature it takes is always a part of a circle. Two lines drawn from the center to the vertexes define the included angle. This center moves along a line as the bulge factor changes. As the center gets closer to the arc, the angle gets larger. If the center moves far away the included angle gets small, the tangent of that angle is small, the arc is nearly a straight line, and the Bulge factor is small.

The gist of the code. Vertexes start numbering with zero.

Dim plineObj As AcadLWPolyline
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points_array)
plineObj.SetBulge 3, -0.5

what does an even number 0.5 Bulge factor give?
2017-01-11_1

what Bulge factor would give an included angle of 90 deg?

2017-01-11_2

since B = TAN(PI/8) this can be entered directly in code

Sub B2_test()
Call connect_acad
Dim pt As Variant

pt = Array(0, 0, Cos(Pi / 4), Sin(-Pi / 4), Cos(Pi / 4), Sin(Pi / 4))
Call draw_array(pt)
global_plineobj.SetBulge 1, Tan(Pi / 8)

End Sub

To create a rounded fillet the vertexes of the arc have to be encoded in the square edge polyline, then rounded.
The B value for 90 degrees is 90/4 or 1/4 * pi/2. Here is a program to create a filleted rectangle of any size with any radius at any location. (the draw_array sub is posted previously)

2017-01-13_1

Sub B2_test_rectangle()
Call connect_acad
Dim pt As Variant
 Dim x1 As Double, x2 As Double, x3 As Double, x4 As Double
 Dim y1 As Double, y2 As Double, y3 As Double, y4 As Double
 Dim A As Double, B As Double, R As Double, Dx As Double, Dy As Double
'A is width X
'B is height Y
'R is fillet radius
'Dx and Dy are coordinates for lower left corner

A = 4
B = 5
R = 1
Dx = 2
Dy = 2
 
 x1 = Dx
 x2 = Dx + R
 x3 = A + Dx - R
 x4 = A + Dx
 
 y1 = Dy
 y2 = Dy + R
 y3 = B + Dy - R
 y4 = B + Dy
 
pt = Array(x2, y1, x3, y1, x4, y2, x4, y3, x3, y4, x2, y4, x1, y3, x1, y2)
Call draw_array(pt)
global_pline.SetBulge 1, Tan(Pi / 8)
global_pline.SetBulge 3, Tan(Pi / 8)
global_pline.SetBulge 5, Tan(Pi / 8)
global_pline.SetBulge 7, Tan(Pi / 8)

End Sub

A slot sub would simply draw a rectangle and use a B factor for the ends to give a 180 degree arc. Here is a routine for both vertical and horizontal slots. This could be combined into one program with a switch or flag. We would also call them with the dimensions as parameters. The B factor is the TAN of one fourth of 180 or pi/4.

2017-01-13_2

Sub B2_horz_slot()
Call connect_acad
Dim pt As Variant
 Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
 Dim A As Double, B As Double, Cx As Double, Cy As Double
'A is length
'B is width
'Cx and Cy are center coordinates

A = 2
B = 0.5
Cx = 3
Cy = 3
 
 x1 = Cx - A / 2
 x2 = Cx + A / 2
 
 y1 = Cy - B / 2
 y2 = Cy + B / 2
 
pt = Array(x1, y1, x2, y1, x2, y2, x1, y2)
Call draw_array(pt)
global_pline.SetBulge 1, Tan(Pi / 4)
global_pline.SetBulge 3, Tan(Pi / 4)
Call draw_point(Cx, Cy, 0) 'this draws a point for reference
End Sub


Sub B2_vert_slot()
Call connect_acad
Dim pt As Variant
 Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
 Dim A As Double, B As Double, Cx As Double, Cy As Double
'A is length
'B is width
'Cx and Cy are center coordinates

A = 2
B = 0.5
Cx = 3
Cy = 3
 
 x1 = Cx - B / 2
 x2 = Cx + B / 2
 
 y1 = Cy - A / 2
 y2 = Cy + A / 2
 
pt = Array(x1, y1, x2, y1, x2, y2, x1, y2)
Call draw_array(pt)
global_pline.SetBulge 0, Tan(Pi / 4)
global_pline.SetBulge 2, Tan(Pi / 4)
Call draw_point(Cx, Cy, 0)
End Sub

autodesk (or somebody) made the B factor the tan of one fourth the included angle. As the included arc varies from zero to almost 360, one fourth of that angle varies from zero to almost 90, and the tangent of that angle (Bulge Factor B) varies from zero to infinity. Because of the imprecision of doubles, Tan(Pi/2) should give an error, the slope of a vertical line, divide by zero, but the imprecision causes an arc with a very large radius.

Autocad VBA Parametrics – 2 – Polyline Method

The autocad lightweightpolyline is the method of choice for drawing parametric plane figures if it is an option. But assembling an array of 30 or so points can be tedious. Here is a sub i wrote several months ago, and to be honest, it is a complete mystery now. the only way i can work on it is to plot it out and start listing points. So i am going to generalize the method and come up with an easier standard procedure for drawing parametric polyline objects.


Sub orig_OS_skin(A As Double, B As Double)
    Dim objent As AcadLWPolyline
    Dim pt(1 To 36) As Double
    
    pt(1) = 0.21875: pt(2) = A + 0.5 - 1
    pt(3) = 0.21875: pt(4) = A + 0.5
    pt(5) = 0: pt(6) = A + 0.5
    pt(7) = 0: pt(8) = 0
    pt(9) = B + 0.5 - 1.25: pt(10) = 0
    pt(11) = B + 0.5 - 1.0625: pt(12) = 0.1875
    pt(13) = B + 0.5: pt(14) = 0.1875
    pt(15) = B + 0.5: pt(16) = 0.40625
    pt(17) = B + 0.5 - 0.875: pt(18) = 0.40625
    pt(19) = B + 0.5 - 0.875: pt(20) = 0.34375
    pt(21) = B + 0.5 - 0.0625: pt(22) = 0.34375
    pt(23) = B + 0.5 - 0.0625: pt(24) = 0.25
    pt(25) = B + 0.5 - 1.08839: pt(26) = 0.25
    pt(27) = B + 0.5 - 1.27589: pt(28) = 0.0625
    pt(29) = 0.0625: pt(30) = 0.0625
    pt(31) = 0.0625: pt(32) = A + 0.5 - 0.0625
    pt(33) = 0.15625: pt(34) = A + 0.5 - 0.0625
    pt(35) = 0.15625: pt(36) = A + 0.5 - 1
    Set objent = acadDoc.ModelSpace.AddLightWeightPolyline(pt)
    objent.Closed = True
    objent.Update
       
    Set objpersistent = objent
End Sub

the first task is to draw a single polyline object. You cannot automate an object if you cannot draw it. if you have drawn it 100 times you will do a better job automating it than if you have barely drawn it. Just like plotting a curve, place it as conveniently as possible at 0,0. Visualize it sitting on the xy axis. Keep your parametric variables as convenient as possible. Start listing points by moving in the direction of the positive X axis. sweep around the screen in a counterclockwise direction as a standard procedure. Locate the first point at 0,0 if possible. The second point should be to the right. Use excel to list just the X values. it is simpler to separate the listings of X and Y values and measure or calculate them separately. Work in the parametric calculations as you go. Make dimensions and measurements on the drawing as needed. After you have gone all around the object listing the X values, do the same thing for Y. This is the key step.

2016-09-18_1

The program listing above that dimensions an array (1 to 36) for 18 points then loads a value into each index location is the brute force normal straightforward approach. We can instead create a polyline wrapper program. The array function only requires the data to be separated by commas. the Polyline method will not use that array directly, but we can create a transfer method in the wrapper. the wrapper will also measure the length of the array. Create a new sub and paste the values just entered into the spreadsheet into the sub.

Sub new_poly_draw(A As Double, B As Double)
Dim pt As Variant
pt = array(

Paste here

Call draw_array(pt)
End Sub
Sub new_poly_draw(A As Double, B As Double)
Dim pt As Variant
pt = array(

0   0
B-1.25  0
B-1.0625    0.1875
B 0.1875
B 0.40625
B-.875  0.40625
B-.875  0.34375
B-.0625 0.34375
B-.0625 0.25
B-1.0884    0.25
B-1.2759    0.0625
0.0625  0.0625
0.0625  A-.0625
0.15625 A-.0625
0.15625 A-1
0.21875 A-1
0.21875 A
0   A

Call draw_array(pt)
End Sub

now put commas between values and put your line continuations wherever you want.

Sub new_poly_draw(A As Double, B As Double)
Dim pt As Variant
        
pt = Array(0, 0, B - 1.25, 0, B - 1.0625, 0.1875, _
B, 0.1875, B, 0.40625, B - 0.875, 0.40625, B - 0.875, 0.34375, _
B - 0.0625, 0.34375, B - 0.0625, 0.25, B - 1.0884, 0.25, B - 1.2759, 0.0625, _
0.0625, 0.0625, 0.0625, A - 0.0625, 0.15625, A - 0.0625, 0.15625, A - 1, _
0.21875, A - 1, 0.21875, A, 0, A)
 
 Call draw_array(pt)
End Sub

and you are done, because you have this wrapper to run it

Sub draw_array(pt As Variant)
     Dim pt2() As Double
     Dim objent As AcadLWPolyline
     Dim i As Integer
     Dim lower As Integer, upper As Integer
     lower = LBound(pt)
     upper = UBound(pt)
     
     ReDim pt2(lower To upper)
     For i = lower To upper
     pt2(i) = pt(i)
     Next i
    
     Set objent = acadDoc.ModelSpace.AddLightWeightPolyline(pt2)
         objent.Closed = True
         objent.Update

Set objpersistent = objent

End Sub

objpersistent is a public variable that allows you to move this piece into position in the calling program.