Autocad Ellipse

The Ellipse

2017-01-26_1

Autocad has an ellipse object. The AddEllipse method takes a center point, a second point which is the end of the major axis, and a factor autodesk calls RadiusRatio, which is just b / a. This is not the same thing as Eccentricity which is c / a, though similar but inverse and they both must be less than 1. I have not seen RadiusRatio in a math book. RadiusRatio gives a circle if it is equal to 1. If it is greater than 1 it throws an error. Eccentricity is a math term and gives a circle when it is zero. If it were 1 i believe the ellipse would collapse to a straight line.

To create an autocad vba ellipse with vertical axis, make the second point, MajorAxis, vertical above the center point. Autocad gives no indication where the Focus is. It has to be calculated from the values of A and B.

2017-01-26_2

Sub init_frm_ellipse()
a = frm_Ellipse.txt_a1
b = frm_Ellipse.txt_b1
End Sub

Sub horz_new_ellipse()
'AddEllipse(Center, MajorAxis, RadiusRatio)
'RadiusRatio must be less than or equal to 1
'MajorAxis is a relative point off the center, not an absolute point
Call connect_acad
Call init_frm_ellipse

Dim obj_ellipse As AcadEllipse
Dim ptctr(0 To 2) As Double
Dim pta(0 To 2) As Double
Call initpt(ptctr, 0, 0, 0)
Call initpt(pta, a, 0, 0)

Set obj_ellipse = acadDoc.ModelSpace.AddEllipse(ptctr, pta, b / a)
obj_ellipse.Update
End Sub

Sub vert_new_ellipse()
Call connect_acad
Call init_frm_ellipse

Dim obj_ellipse As AcadEllipse
Dim ptctr(0 To 2) As Double
Dim pta(0 To 2) As Double
Call initpt(ptctr, 0, 0, 0)
Call initpt(pta, 0, a, 0)

Set obj_ellipse = acadDoc.ModelSpace.AddEllipse(ptctr, pta, b / a)
obj_ellipse.Update
End Sub

The autodesk method advantage is that by specifying a center, then a relative point from the center for the end of the major axis, the ellipse can be turned to any angle. With some simple trig we can accept input in degrees and calculate the major axis vertex.

2017-01-27_1

 Function deg2rad(deg As Double) As Double
deg2rad = deg * Pi / 180
End Function

Sub init_frm_ellipse()
a = frm_Ellipse.txt_a1
b = frm_Ellipse.txt_b1
c = frm_Ellipse.txt_c1
End Sub

Sub new_ellipse()
'AddEllipse(Center, MajorAxis, RadiusRatio)
'RadiusRatio must be less than or equal to 1
'MajorAxis is a point, not a length
Call connect_acad
Call init_frm_ellipse

Dim obj_ellipse As AcadEllipse
Dim ptctr(0 To 2) As Double
Dim pta(0 To 2) As Double
Dim x1 As Double, y1 As Double

x1 = a * Cos(deg2rad(c))
y1 = a * Sin(deg2rad(c))

Call initpt(ptctr, 0, 0, 0)
Call initpt(pta, x1, y1, 0)

Set obj_ellipse = acadDoc.ModelSpace.AddEllipse(ptctr, pta, b / a)
obj_ellipse.Update
End Sub

we can move the ellipse off the center. The input for AddEllipse does not require an absolute point for MajorAxis. It takes a point relative to the center.

2017-01-28_1

Drawing the ellipse is straightforward. calculating the focus and end points to mark them requires some trig to accomodate the angled axes.


Sub new_ellipse()
'takes input from the form
'a major axis
'b minor axis
'd degree of major axis
'h and k, xy values for center of ellipse
'converts input to
'autocad method AddEllipse(Center, MajorAxis, RadiusRatio)
'RadiusRatio must be less than or equal to 1
'MajorAxis is a point relative from the center, not an absolute point
Call connect_acad
Call init_frm_ellipse ' gets the values from the form
Dim obj_ellipse As AcadEllipse
Dim obj_point As AcadPoint

Dim ctr(0 To 2) As Double
Dim pt_a(0 To 2) As Double
Dim x1 As Double, y1 As Double

x1 = a * Cos(deg2rad(d))
y1 = a * Sin(deg2rad(d))

Call initpt(ctr, h, k, 0)
Call initpt(pt_a, x1, y1, 0)

Set obj_ellipse = acadDoc.ModelSpace.AddEllipse(ctr, pt_a, b / a)
obj_ellipse.Update

'to plot points
Dim pt_a1(0 To 2) As Double
Dim pt_a2(0 To 2) As Double
Dim pt_b1(0 To 2) As Double
Dim pt_b2(0 To 2) As Double
Dim pt_f1(0 To 2) As Double
Dim pt_f2(0 To 2) As Double

Dim fx1 As Double, fy1 As Double, fx2 As Double, fy2 As Double
Dim ax1 As Double, ay1 As Double, ax2 As Double, ay2 As Double
Dim bx1 As Double, by1 As Double, bx2 As Double, by2 As Double

'c is the focal distance from ctr
c = (a ^ 2 - b ^ 2) ^ 0.5
fx1 = h + c * Cos(deg2rad(d))
fy1 = k + c * Sin(deg2rad(d))
fx2 = h - c * Cos(deg2rad(d))
fy2 = k - c * Sin(deg2rad(d))

bx1 = h + b * Cos(deg2rad(d + 90))
by1 = k + b * Sin(deg2rad(d + 90))

bx2 = h - b * Cos(deg2rad(d + 90))
by2 = k - b * Sin(deg2rad(d + 90))

ax1 = h + a * Cos(deg2rad(d))
ay1 = k + a * Sin(deg2rad(d))

ax2 = h - a * Cos(deg2rad(d))
ay2 = k - a * Sin(deg2rad(d))

Call initpt(pt_a1, ax1, ay1, 0)
Call initpt(pt_a2, ax2, ay2, 0)
Call initpt(pt_b1, bx1, by1, 0)
Call initpt(pt_b2, bx2, by2, 0)
Call initpt(pt_f1, fx1, fy1, 0)
Call initpt(pt_f2, fx2, fy2, 0)

Set obj_point = acadDoc.ModelSpace.AddPoint(ctr)

Set obj_point = acadDoc.ModelSpace.AddPoint(pt_a1)
Set obj_point = acadDoc.ModelSpace.AddPoint(pt_a2)

Set obj_point = acadDoc.ModelSpace.AddPoint(pt_b1)
Set obj_point = acadDoc.ModelSpace.AddPoint(pt_b2)

Set obj_point = acadDoc.ModelSpace.AddPoint(pt_f1)
Set obj_point = acadDoc.ModelSpace.AddPoint(pt_f2)
Update

End Sub

In astronomy, planets orbit around the sun in ellipses with the sun at one focus. To draw these orbits we need to input the different numbers but always draw one focus, the sun, at the origin.

2017-01-27_2

orbits of the nine planets (simplified with major axes aligned, no inclination). The sun and all planets are drawn full size, but the distances of the orbits are so vast they are not seen. this is much more fun to do yourself to zoom around and get a feel for the distance than to look at a screenshot.

the astronomy book gives the half major axis in (x 10^6 km), Orbital Eccentricity, and planet radius in km. those are the inputs. The value for Uranus caused Long and Double variable types to overflow but i had no issues using Currency data type. don’t base your senior thesis on this, i dont have supervision. it gives a visually correct orbit for pluto that it actually crosses inside neptune’s orbit because of pluto’s higher eccentricity. there are other 3D factors i do not take into consideration, inclination – ellipse tilt – and two other twists in 3D space. so neptune and pluto can never collide.

2017-01-27_3

Public Const xkm As Currency = 1000000

Sub solar_system()
Call connect_acad
'testCall planetary_ellipse(6, 0.5, 1)

Dim pt0(0 To 2) As Double
Call initpt(pt0, 0, 0, 0)

Dim obj_sphere As Acad3DSolid
'this is the sun
Set obj_sphere = acadDoc.ModelSpace.AddSphere(pt0, 696000)

'mercury
Call planetary_ellipse(57.9 * xkm, 0.206, 2440)

'venus
Call planetary_ellipse(108.2 * xkm, 0.007, 6052)

'earth
Call planetary_ellipse(149.6 * xkm, 0.017, 6378)

'mars
Call planetary_ellipse(227.9 * xkm, 0.093, 3397)

'jupiter
Call planetary_ellipse(778.4 * xkm, 0.048, 71492)

'saturn
Call planetary_ellipse(1427 * xkm, 0.054, 60268)

'too large
'uranus
Call planetary_ellipse(2871 * xkm, 0.047, 25559)

'neptune
Call planetary_ellipse(4498 * xkm, 0.009, 24764)

'pluto
Call planetary_ellipse(5906 * xkm, 0.249, 1195)

End Sub


Sub planetary_ellipse(a As Currency, e As Double, r As Long)
'a is major axis km
'e is eccentricity
'r is planetary equatorial radius in km

'AddEllipse(Center, MajorAxis, RadiusRatio)
'RadiusRatio must be less than or equal to 1
'MajorAxis is a point, not a length

Dim b As Double
Dim c As Double
Dim obj_ellipse As AcadEllipse
Dim obj_point As AcadPoint


Dim ctr(0 To 2) As Double
Dim f1(0 To 2) As Double
Dim f2(0 To 2) As Double
Dim pt_a(0 To 2) As Double
Dim pt_p(0 To 2) As Double
Dim a_vector(0 To 2) As Double

c = a * e
b = a * (1 - e ^ 2) ^ 0.5

Call initpt(ctr, c, 0, 0)
Call initpt(f1, 0, 0, 0)
Call initpt(f2, 2 * c, 0, 0)
Call initpt(pt_a, a + c, 0, 0)
Call initpt(pt_p, c - a, 0, 0)

Call initpt(a_vector, 1 * a, 0, 0)

Set obj_ellipse = acadDoc.ModelSpace.AddEllipse(ctr, a_vector, b / a)
obj_ellipse.Update

Dim obj_sphere As Acad3DSolid
Set obj_sphere = acadDoc.ModelSpace.AddSphere(pt_a, r)
Set obj_sphere = acadDoc.ModelSpace.AddSphere(pt_p, r)

End Sub

Autocad VBA Logo Turtle Graphics

Logo was a lisp like educational language designed to introduce children to coding. I believe there may be no serious impediments to implementing an experimental version in Autocad VBA. This is a work in process, first post is proof of concept. The full implementation is yet to be planned. I wont worry too much about deviating from standard logo methods or syntax. If i hit a problem that cannot be coded around, that will be information gained. I believe the concepts may turn out to be useful for more general VBA parametric autocad code.

For all of my projects, I code in an Excel XLSM file. I have a standard ACAD_CONNECT sub i use, and reference the Autocad Type Library in the Excel VBAProject. i have never downloaded the Autocad VBA implementation. It is not necessary to code Autocad VBA. I use the VBA editor provided routinely in Excel.

The fundamental element of turtle geometry is the current position of the pen, and the heading or direction it is pointing. This prototype will be 2D, so we need a global variable for the X and Y position, and a variable for the heading. We will keep heading in degrees and convert it in the low level subs to radians.

The first thing we will need is a line subroutine that takes logo style input – current point, distance, and heading – to draw the line and change the pen position to the end of the line. The user wont call this sub directly but will use std routines like Forward, PenUP, Right, Left, etc.

Option Explicit
 Public px As Double 'position x
 Public py As Double 'position y
 Public hxy As Double 'heading degree


Sub line_hd(x1 As Double, y1 As Double, dist As Double, heading As Double)
' call line_t(x1,y1,dist,heading)
' heading in degrees

Dim lineobj As AcadLine
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
Dim heading_radian As Double

pt1(0) = x1: pt1(1) = y1: pt1(2) = 0
heading_radian = heading * Pi / 180

'px and py are global position
px = px + dist * Cos(heading_radian)
py = py + dist * Sin(heading_radian)

pt2(0) = px: pt2(1) = py: pt2(2) = 0
Set lineobj = acadDoc.ModelSpace.AddLine(pt1, pt2)

Update
End Sub

standard logo subroutines FORWARD, RIGHT, LEFT and BACK to get started are pretty simple at this point. i dont have a PENUP, PENDOWN yet that will modify these.

Sub forward(dist As Double)
Call line_hd(px, py, dist, hxy)
End Sub

Sub right(deg As Double)
hxy = hxy - deg
End Sub

Sub left(deg As Double)
hxy = hxy + deg
End Sub

Sub back(dist As Double)
Dim heading_radian As Double
heading_radian = hxy * Pi / 180
px = px - (dist * Cos(heading_radian))
py = py - (dist * Sin(heading_radian))
End Sub

a sample user prototype sub and init sub helper.

 Sub init_turtle()
 Call connect_acad
 px = 0
 py = 0
 hxy = 0
 End Sub
 
 Sub to_honeycomb()
  init_turtle
 Dim i As Integer, j As Integer

For j = 1 To 3
For i = 1 To 6
forward 6
left 60
Next i

left 120
Next j

End Sub

2017-01-15_1

 Sub to_star()
 init_turtle
 Dim i As Integer
 
 For i = 1 To 5
 forward 6
 right 144
 Next i
 
 End Sub
 

2017-01-15_2

the circle routine according to python turtle graphics just takes a radius. from the position and heading of the turtle, it makes a 360 arc back to the starting point. if the radius is positive, it turns counterclockwise, if negative then opposite. the task then is to run a normal perpendicular off the heading vector the same distance as the radius to find the center.

this is a little messy, i dont think it will stay this way.

first a demo calling program, then the circle primitive code.

Sub test_circle()
init_turtle

For i = 1 To 21
forward 6
right 15 + i
forward 6
curcle 3
forward 3
curcle -3
forward 6
curcle -3
forward 3
curcle 3
Next i

End Sub

Sub curcle(radius As Double)
Call circle_turtle(px, py, radius, hxy)
End Sub


Sub circle_turtle(x1 As Double, y1 As Double, radius As Double, hxy As Double)
' circle wrapper
' call circle_hd(x1,y1,radius,heading)
' heading in degrees
Dim newheading As Double
Dim newheading_radian As Double
Dim Cx As Double, Cy As Double
Dim circleobj As AcadCircle
Dim pt2(0 To 2) As Double

If radius > 0 Then
newheading = hxy + 90
Else
newheading = hxy - 90
End If

newheading_radian = newheading * Pi / 180

'px and py are global position
'we are calculating circle center but not changing position
Cx = px + Abs(radius) * Cos(newheading_radian)
Cy = py + Abs(radius) * Sin(newheading_radian)
pt2(0) = Cx: pt2(1) = Cy: pt2(2) = 0

Set circleobj = acadDoc.ModelSpace.AddCircle(pt2, Abs(radius))

Update
End Sub

2017-01-16_1

more to come

Autocad VBA Parameters -3-

A non-trivial VBA parametric project requires some structure to re-use standard techniques and a guide drawing to be made with user parameters identified that specifies the point values to be drawn. This sample project is a sheet metal frame that would be used to cap a hole. There are only two parts, top/bottom and side, but they are drawn both in front assembly and laid out flat before bending, so there are 4 basic drawing sub-routines. The drawing subroutines create geometry. Their only other job is to initialize bounding box variables so the calling program has the option to move into assembly, block, and/or rotate.

The parts are always drawn with lower left corner at or near 0,0. The master drawing is created manually before the programming is started. If carefully done, and revised until it works as needed, it will make the programming much easier.

2016-12-31_1

Give each project its own module. It solves naming issues if each project is given a simple project ID, then prefix all the subs with the ID. The draw subs are at the bottom and the controlling program at the top. The draw subs are completed first, all in a similar manner. Again it makes programming much simpler if all the controlling sketches are laid out consistently and thoroughly. The only variables passed are the user variables. Calculations are made in the drawing sub. The sketches should be consistent – variable D1 in one sketch is the same value D1 in another sketch.


Sub B1_chan_top_bent(A As Double, D As Double, E As Double)
Dim pt As Variant
Dim A1 As Double, A2 As Double
      A1 = A + D + D
      A2 = A + D

'bounding box pt_ll and pt_ur are global vars
Call initpt(pt_ll, -1, -1, 0)
Call initpt(pt_ur, A1 + 2, D + 2, 0)
   
pt = Array(0, E, D, E, D, 0, _
            A2, 0, A2, E, A1, E, _
            A1, D, 0, D)
Call draw_array(pt)

acadDoc.ActiveLayer = acadDoc.Layers.Item("Hidden")
Call line(D, E, A2, E)

'each drawing sub re-sets current layer to 0
acadDoc.ActiveLayer = acadDoc.Layers.Item("0")
Update
End Sub


Sub B1_chan_side_bent(B As Double, D As Double, E As Double)
Dim pt As Variant
Dim B1 As Double
B1 = B + E + E

'bounding box
  Call initpt(pt_ll, -1, -1, 0)
  Call initpt(pt_ur, B1 + 2, D + 2, 0)

pt = Array(0, 0, B1, 0, B1, D, 0, D)
Call draw_array(pt)

acadDoc.ActiveLayer = acadDoc.Layers.Item("Hidden")
Call line(0, E, B1, E)

acadDoc.ActiveLayer = acadDoc.Layers.Item("0")
Update
End Sub


Sub B1_chan_top_flat(A As Double, C As Double, D As Double, E As Double)
Dim pt As Variant
Dim A1 As Double, A2 As Double, C1 As Double, C2 As Double, D1 As Double
    A1 = A + D + D
    A2 = A + D
    D1 = D - E
    C1 = C + D1
    C2 = C + D1 + D1
    
 'bounding box
   Call initpt(pt_ll, -1, -1, 0)
   Call initpt(pt_ur, A1 + 2, C2 + 2, 0)
   
pt = Array(0, 0, A1, 0, A1, D1, _
        A2, D1, A2, C1, A1, C1, _
        A1, C2, 0, C2, 0, C1, _
        D, C1, D, D1, 0, D1)
Call draw_array(pt)

acadDoc.ActiveLayer = acadDoc.Layers.Item("UP")
Call line(D, D1, A2, D1)
Call line(D, C1, A2, C1)

acadDoc.ActiveLayer = acadDoc.Layers.Item("0")
Update
End Sub



Sub B1_chan_side_flat(B As Double, C As Double, D As Double, E As Double)
Dim pt As Variant
Dim B1 As Double, C1 As Double, C2 As Double, D1 As Double
B1 = B + E + E
D1 = D - E
C1 = C + D1
C2 = C + D1 + D1

'bounding box
 Call initpt(pt_ll, -1, -1, 0)
 Call initpt(pt_ur, B1 + 2, C2 + 2, 0)

'outside box
pt = Array(0, 0, B1, 0, B1, C2, 0, C2)
Call draw_array(pt)

acadDoc.ActiveLayer = acadDoc.Layers.Item("UP")
Call line(0, D1, B1, D1)
Call line(0, C1, B1, C1)

acadDoc.ActiveLayer = acadDoc.Layers.Item("0")
Update
End Sub

These can be called in any order. In this project i call the bent pieces first. I block them, then move them to an assembly position, using an arbitrary location (K, K). The side piece is drawn horizontal, so it is first rotated and moved about the same point. Again these points are located first on the sketches. The parts are blocked with a sub that accepts the bounding box coordinates, a name and a point for insert point. That routine works with any similar project. It creates a selection set using the bounding box, creates the block with name and insert point, adds the selection set entities to the block, erases the original entities and finally inserts the block. It assigns the block to a global var so the calling program can move it. These routines are in their own module shared by multiple projects.

Sub make_ss_blk(pt_ll() As Double, pt_ur() As Double, strblkname As String, pt_insert() As Double)
  'creates new ss, adds items to it with a crossing window
  'creates new block, adds ss to blk with counting loop
  'deletes original entities and inserts the block
  'creates an object reference to the block objpersistent for moving/rotating
  
    Dim objss As AcadSelectionSet
    Dim objBlock As AcadBlock
    Dim i As Integer
        
    Call addss("my_block")
    Set objss = acadDoc.SelectionSets.Item("my_block")
       objss.Select acSelectionSetCrossing, pt_ll, pt_ur
  
 ' make_blk(objss, strblkname, pt_insert)
    On Error Resume Next
    Set objBlock = acadDoc.Blocks.Item(strblkname)
    objBlock.Delete
    On Error GoTo 0
    
    Set objBlock = acadDoc.Blocks.Add(pt_insert, strblkname)
    
    ReDim Obj(0 To objss.Count - 1) As AcadObject
     'Copy each object selected in the block
    For i = 0 To objss.Count - 1
    Set Obj(i) = objss(i)
    Next i
    acadDoc.CopyObjects Obj, objBlock
   
    objss.Erase
    objss.Delete
    
    Set objpersistent = acadDoc.ModelSpace.InsertBlock(pt_insert, strblkname, 1, 1, 1, 0)
     
End Sub

Sub addss(strname As String)
    Dim objss As AcadSelectionSet
   On Error Resume Next
    If "" = strname Then
    Exit Sub
    End If
    
    Set objss = acadDoc.SelectionSets.Item(strname)
    objss.Delete
    Set objss = acadDoc.SelectionSets.Add(strname)
    If objss Is Nothing Then
    MsgBox "unable to add " & strname
    Else
    'MsgBox "added"
    End If
End Sub

The main calling program will vary depending on interface. Here is the basic one with variable values called out near the top.


Option Explicit
'ProjID B1
'Project Name - Inside Cap Channel
'ProjDesc - to cap existing hole
'a b c d e

Public Const Pi As Double = 3.14159265359
Public Const halfPI = Pi / 2

Public pt0(0 To 2) As Double
Public pt_ll(0 To 2) As Double
Public pt_ur(0 To 2) As Double

Public objss As AcadSelectionSet
Public objent As AcadEntity
Public objpersistent As AcadEntity


Sub B1_draw_inside_cap_chan_assy()

Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
Dim K As Double
K = 50
Call init_part

'assy vars
Dim A As Double, B As Double, C As Double, D As Double, E As Double
'A is X, B is Y, C is ID THK, D is BENT FLG, E is GA

A = 24
B = 36
C = 4.125
D = 2.5
E = 0.125

Call B1_chan_top_bent(A, D, E)
Call make_ss_blk(pt_ll, pt_ur, "B1_chan_top", pt0)
Call initpt(pt1, A / 2 + D, 0, 0)
Call initpt(pt2, K, K + B / 2, 0)
objpersistent.Move pt1, pt2

Call B1_chan_side_bent(B, D, E)
Call make_ss_blk(pt_ll, pt_ur, "B1_chan_side", pt0)
Call initpt(pt1, B / 2 + E, 0, 0)
Call initpt(pt2, K + A / 2, K, 0)
objpersistent.Rotate pt1, -halfPI
objpersistent.Move pt1, pt2

Call B1_chan_top_flat(A, C, D, E)
addss ("FlatPattern")
Set objss = acadDoc.SelectionSets.Item("FlatPattern")
objss.Select acSelectionSetWindow, pt_ll, pt_ur

Call initpt(pt2, 0, 48, 0)
    For Each objent In objss
    objent.Move pt0, pt2
    Next

Call B1_chan_side_flat(B, C, D, E)
addss ("FlatPattern")
Set objss = acadDoc.SelectionSets.Item("FlatPattern")
objss.Select acSelectionSetWindow, pt_ll, pt_ur

Call initpt(pt2, 0, 24, 0)
    For Each objent In objss
    objent.Move pt0, pt2
    Next

Call initpt(pt2, K, K, 0)
Call cap_chan_sect(C + (2 * E), D, E)
objpersistent.Move pt0, pt2

Update
End Sub

This creates –
2016-12-31_2

The section view is a straightforward drawing sub

Sub cap_chan_sect(C As Double, D As Double, E As Double)
Dim pt As Variant
   Call initpt(pt_ll, -1, -1, 0)
   Call initpt(pt_ur, D + 2, C + 2, 0)
   
pt = Array(0, 0, D, 0, D, E, E, E, E, C - E, D, C - E, D, C, 0, C)
Call draw_array(pt)

Update
End Sub

The init-part sub is simply because i like to be able to run programs in a completely new blank drawing. it creates layers, but also makes the initial connection between excel VBA code and autocad.

Sub init_part()
 Call initpt(pt0, 0, 0, 0)
 Call connect_acad
 Call newlayer("UP", 4, acLnWtByLwDefault, "Continuous")
 Call newlayer("Down", 6, acLnWtByLwDefault, "Hidden")
 Call newlayer("Hidden", 6, acLnWtByLwDefault, "Hidden")
 acadDoc.ActiveLayer = acadDoc.Layers.Item("0")
End Sub

Anything you can draw manually with specificity and clearly defined variables you can automate. It is only slightly more effort to automate dimensioning. Practice will refine your technique.

Creating the Graph Point Data

Autocad AddLightWeightPolyline method requires an array of doubles. It does not require the lowerbound of the array to be zero. An array simply has to have an even number of elements, one element for each X and each Y alternating. (x1, y1, x2, y2, x3, y3…) For indexes and loops I typically use the counting numbers, which do not include zero. I am evaluating an autocad work-alike program that is similar but requires arrays to be zero-based. It does not throw an error with a one-based array but results are a failure. it creates zero values for non-existent indexes that it expects. However there is no reason the arrays cannot be zero-based so they run in both packages. To that end for that reason i am re-doing the graph loops.

Only the array needs to be zero based. The loop still executes one time for each point. The index of the array starts with zero.

Calculation of points for Coordinate XY graphing –

2016-10-03_1

Autocad does not care what indexes the array pt (below) was created with. The work-alike absolutely requires a starting index of zero.

Dim plineobj As AcadLWPolyline
Set plineobj = acadDoc.ModelSpace.AddLightWeightPolyline(pt)

in line drawing mode, subtracting lbound from ubound adding one and dividing by two will give the number of points in the array. There is one less line. Since we know lbound is zero we could remove that. The loop iterates once for each line drawn. We could do the loop to handle any lbound value, but it would be a little messy with no immediate benefit. For now we expect a zero base array.

Sub draw_lines(ByRef pt() As Double)
Dim lineobj As AcadLine
Dim i As Integer, numpts As Integer, numlines As Integer
Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double

numpts = (UBound(pt) - LBound(pt) + 1) / 2
numlines = numpts - 1

'this requires a zero base array
For i = 1 To numlines
x1 = pt(i * 2 - 2)
y1 = pt(i * 2 - 1)
x2 = pt(i * 2)
y2 = pt(i * 2 + 1)

pt1(0) = x1: pt1(1) = y1: pt1(2) = 0
pt2(0) = x2: pt2(1) = y2: pt2(2) = 0
Set lineobj = acadApp.ActiveDocument.ModelSpace.AddLine(pt1, pt2)

Next i

Update
End Sub

Lines w/limits mode we use when the Y value approaches infinity, such as y=1/x near x=0. It is otherwise the same.

Sub draw_lines_wlimits(xlim As Double, ylim As Double, ByRef pt() As Double)
Dim lineobj As AcadLine
Dim i As Integer, numpts As Integer, numlines As Integer
Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double

numpts = (UBound(pt) - LBound(pt) + 1) / 2
numlines = numpts - 1

'this requires a zero base array
For i = 1 To numlines
x1 = pt(i * 2 - 2)
y1 = pt(i * 2 - 1)
x2 = pt(i * 2)
y2 = pt(i * 2 + 1)

If Abs(x1) < xlim And Abs(y1) < ylim And Abs(x2) < xlim And Abs(y2) < ylim Then
pt1(0) = x1: pt1(1) = y1: pt1(2) = 0
pt2(0) = x2: pt2(1) = y2: pt2(2) = 0
Set lineobj = acadApp.ActiveDocument.ModelSpace.AddLine(pt1, pt2)
End If
Next i

Update
End Sub

point mode


Sub draw_points(ByRef pt() As Double)
Call pointmode
Dim pointobj As AcadPoint
Dim i As Integer, numpts As Integer
Dim x1 As Double, y1 As Double

Dim pt1(0 To 2) As Double
numpts = (UBound(pt) - LBound(pt) + 1) / 2

'this requires a zero base array
For i = 1 To numpts
x1 = pt(i * 2 - 2)
y1 = pt(i * 2 - 1)
pt1(0) = x1: pt1(1) = y1: pt1(2) = 0
Set pointobj = acadDoc.ModelSpace.AddPoint(pt1)
Next i

Update
End Sub

the Cochleoid

the Cochleoid is a polar spiral that spirals in on itself, because Sin A varies between -1 and 1, but A gets ever larger.

2016-08-29_1

at point 8 A is 210, not 30, but because the Sin is negative, R is negative. The graph passes thru 0,0 every time the sin is zero.

2016-08-29_2

running the graph from negative 1080 (-6 pi) to -1 (to avoid divide by zero error) draws the mirror image graph from the inside out.

2016-08-29_3

2016-08-29_4

wolfram reference
http://mathworld.wolfram.com/Cochleoid.html

Acad TableStyle full method

2016-08-28_1

Acad Tablestyle can be programmed efficiently without duplicating code using a global variable for the Tablestyle object. While it is tempting to re-create the Autocad Tablestyle dialog in a VBA form, it would be difficult to improve on it and it would be a lot of work. The following program is a more or less full implementation of the tablestyle creation in code. Doubtless there could be some improvement of the variable listings, making them easier to create a list of standard tablestyles. This will do for a template in how tablestyles are made. an input form could interface with this style easily.


Option Explicit

Public TS As AcadTableStyle

'tablestyle creation all in code, no form input
'based on the autocad tablestyle dialog
'sub calls are closely related to the tabs General, Text and Borders
'each sub is called 3 times with rowtype, just like the dialog
'purpose would be to create a favorite std style with all variables in code
'but form input would go thru this format also
'to create a 2nd style copy this header sub and modify values

Sub make_table_style_std()
    Call connect_acad
    Call set_text_style 'for now so we have textstyle selection
    Dim col As AcadAcCmColor
    Set col = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.20")
    Dim rowtypes As Long
    Dim tablestylename As String
    
     'set up vars for general tab
    Dim blncolor As Boolean
    Dim alignment As Integer
    Dim marginhoriz As Double, marginvert As Double
    Dim blnmerge As Boolean
    
     'set up vars for text tab
    Dim textstyle As String
    Dim textheight As Double
    
     'set up vars for borders tab
    Dim lineweight As Integer
    
    tablestylename = "Tb_Style1"
'first call that creates or sets the tablestyle
Call table_style_std(tablestylename)

'***************************
 'set up vars for general tab
        
    Call col.SetRGB(0, 0, 0)
    blncolor = False
    alignment = 5 'centered
    marginhoriz = 0.06
    marginvert = 0.06
    blnmerge = False

'call ts_general 3 times once for each row type, chg vars as needed
Call ts_General(acTitleRow, blncolor, col, alignment, marginhoriz, marginvert)

Call ts_General(acHeaderRow, blncolor, col, alignment, marginhoriz, marginvert)
alignment = 6 'right

Call ts_General(acDataRow, blncolor, col, alignment, marginhoriz, marginvert)

Call ts_merge

 '************************
 'set up vars for text tab
    textstyle = "Tahoma"
    textheight = 0.1875
    Call col.SetRGB(0, 0, 0)
     
'call ts_text 3 times once for each row type, chg vars as needed
Call ts_Text(acTitleRow, textstyle, textheight, col)
    textheight = 0.125

Call ts_Text(acHeaderRow, textstyle, textheight, col)
    textheight = 0.09375

Call ts_Text(acDataRow, textstyle, textheight, col)

 '**************************
 'set up vars for borders tab
    lineweight = 40
    Call col.SetRGB(0, 0, 255)
    
 'call ts_border 3 times once for each row type, chg vars as needed
Call ts_Borders(acTitleRow, lineweight, col)

Call ts_Borders(acHeaderRow, lineweight, col)
    lineweight = 30

Call ts_Borders(acDataRow, lineweight, col)
End Sub

'***********

Sub table_style_std(stylname As String)
'main entry called first
    Dim dictionaries As AcadDictionaries
    Dim dictObj As AcadDictionary
    Set dictionaries = acadDoc.Database.dictionaries
    Set dictObj = dictionaries.Item("acad_tablestyle")

    Set TS = dictObj.AddObject(stylname, "AcDbTableStyle")
    TS.Name = stylname
    TS.Description = TS.Name & " TableStyle"
    
   acadDoc.SetVariable ("ctablestyle"), stylname
End Sub

Sub ts_General(rowtypes As Long, blncolor As Boolean, fillcolor As AcadAcCmColor, alignment As Integer, _
               marginhoriz As Double, marginvert As Double)
'skipping format option and type
'merge is handled in its own sub

'seems to be a problem with autodesk help reference
'setbackgroundcolornone true is the only valid input
'that option sets backgroundcolor to none as desired
'which is contrary to activex help

If blncolor Then
TS.SetBackgroundColor rowtypes, fillcolor
Else
TS.SetBackgroundColorNone rowtypes, True
End If

TS.SetAlignment rowtypes, alignment
TS.HorzCellMargin = marginhoriz
TS.VertCellMargin = marginvert

End Sub


Sub ts_merge()
'the enablemergeall statement is functional in styles
'titlesuppressed and headersuppressed are not functional in tablestyle
'although they are documented and do not cause an error - they dont do anything
'whether a created table has a title and header is dictated by table method
    TS.EnableMergeAll "Title", True
    TS.EnableMergeAll "Header", False
    TS.EnableMergeAll "Data", False
'the activex help on enablemergeall seems to indicate 2 integer arguments and a boolean
'whilst the program code example is per above, one string row description and boolean
'which is why i put it in its own sub for clarity
End Sub


Sub ts_Text(rowtypes As Long, textstyle As String, textheight As Double, col As AcadAcCmColor)
 'acDatarow=1 acHeaderrow=4 acTitlerow=2
 TS.SetTextStyle rowtypes, textstyle
 TS.SetTextHeight rowtypes, textheight
 TS.SetColor rowtypes, col
 
'get functtions are similar
 Debug.Print TS.GetTextStyle(rowtypes)
 Debug.Print TS.GetTextHeight(rowtypes)
 Set col = TS.GetColor(rowtypes)
 Debug.Print col.ColorIndex
 Debug.Print col.ColorMethod
 Debug.Print col.ColorName
End Sub


Sub ts_Borders(rowtypes As Long, lineweight As Integer, col As AcadAcCmColor)
   'to set all rowtypes at once use 7 (1+2+4)
   '63 sets all gridlinetypes eg outside inside etc 1, 2, 4, 8, 16, 32
   'somehow you can set the grid linetype eg dashed but i dont see a method
   
   TS.SetGridColor 63, rowtypes, col
   TS.SetGridLineWeight 63, rowtypes, lineweight
   TS.SetGridVisibility 63, rowtypes, True
End Sub