These are found in the first chapter of an old analytic geometry book.
All of Autocad graphics methods use a 3 place array of doubles for the coordinates.
The simplest way to sub this is by passing the static array for the sub to fill data.
Dim PtA(0 To 2) As Double
Call pt1(ptA, 1, 2, 0)
Sub pt1(ByRef pnt() As Double, x As Double, y As Double, z As Double)
pnt(0) = x: pnt(1) = y: pnt(2) = z
This changes ptA in the calling program. Another way is to make a function and pass the array back to a receiving variable.
This requires a dynamic array.
Dim ptA() As Double
ptA = Pt(1, 2, 0)
Function Pt(x As Double, y As Double, z As Double) As Double()
Dim pnt(0 To 2) As Double
pnt(0) = x: pnt(1) = y: pnt(2) = z
Pt = pnt
We can even get away with this – no variables at all.
Set lineAB = acadDoc.ModelSpace.AddLine(Pt(1, 4, 0), Pt(9, 1, 0))
The polarpoint method in utility uses a single variant variable to hold the array.
RetVal = object.PolarPoint(Point, Angle, Distance)
Point Type: Variant (three-element array of doubles)
Return Value Type: Variant (three-element array of doubles)
Dim polarPnt As Variant
Dim basePnt(0 To 2) As Double
polarPnt = ThisDrawing.Utility.PolarPoint(basePnt, angle, distance)
Set lineObj = ThisDrawing.ModelSpace.AddLine(basePnt, polarPnt)
PolarPoint returns an array. You cannot assign to a static array. Dynamic arrays can assign. If the declaration is to a dynamic array with the correct type Double it still works (in my version.)
Dim polarPnt() As Double
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.
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.
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
Euclid’s 2nd proposition draws a line at point A equal in length to a line BC. It uses proposition 1 and is used by proposition 3. I tried to make a generic program I could use for both the primary job of illustrating the theorem and for the purpose of being used by subsequent theorems, but it is simpler to separate those into two sub procedures. The programming was pretty easy except when a line is extended to meet a circle, there are two intersections, and one of them has to be selected. A good illustration with labeled objects helps keep it straight.
In autocad 1-2 is not a problem. The solution would be to copy or move the line endpoint to endpoint. In Euclid, lines cannot be moved. The compass cannot be used to transfer a distance by being picked up off the page. In autocad items are rigid. When two objects the same are copied to the same location they exactly coincide. Euclid’s 4th Axiom is “Things that coincide with one another are equal to one another”. This has caused remarks as to its real meaning. If you cannot move an object to super-impose, how would you know, and even if you could move them, no physical object will perfectly cover another. This common belief, things that are the same coincide, is intended to point to ideal form, like we have in a cad program.
Sub prime_pr2() 'given ptA and lineBC call proposition2 Connect_Acad Dim ptA(0 To 2) As Double Dim ptB(0 To 2) As Double Dim ptC(0 To 2) As Double Dim Ax As Double, Ay As Double Dim Bx As Double, By As Double Dim Cx As Double, Cy As Double Ax = rnddbl(0, 5) Ay = rnddbl(0, 5) Bx = rnddbl(6, 10) By = rnddbl(0, 10) Cx = rnddbl(6, 20) Cy = rnddbl(15, 25) Call pt(ptA, Ax, Ay, 0) Call pt(ptB, Bx, By, 0) Call pt(ptC, Cx, Cy, 0) Call pr2(ptA, ptB, ptC) acadApp.Update End Sub Sub pr2(ptA() As Double, ptB() As Double, ptC() As Double) Dim lineBC As AcadLine Dim lineAB As AcadLine, lineAD As AcadLine, lineBD As AcadLine Dim lineAL As AcadLine, lineBG As AcadLine Dim circH As AcadCircle, circK As AcadCircle Dim r As Double Dim intpts As Variant Dim ptD(0 To 2) As Double Dim ptG(0 To 2) As Double Dim ptL(0 To 2) As Double Set lineBC = acadDoc.ModelSpace.AddLine(ptB, ptC) Set lineAB = acadDoc.ModelSpace.AddLine(ptA, ptB) 'now we need Euclid 1-1 to draw equilateral triangle Call pr2_pr1_sub(ptA, ptB) 'vertex found ptD(0) = ptG1(0) ptD(1) = ptG1(1) ptD(2) = ptG1(2) Set lineAD = acadDoc.ModelSpace.AddLine(ptA, ptD) Set lineBD = acadDoc.ModelSpace.AddLine(ptB, ptD) 'find ptG, do lineBG r = distance(ptB, ptC) Set circH = acadDoc.ModelSpace.AddCircle(ptB, r) intpts = lineBD.IntersectWith(circH, acExtendThisEntity) Call intpts_eval(intpts) 'want ptG intersection farthest from ptD If distance(ptD, ptG1) > distance(ptD, ptG2) Then ptG(0) = ptG1(0) ptG(1) = ptG1(1) ptG(2) = ptG1(2) Else ptG(0) = ptG2(0) ptG(1) = ptG2(1) ptG(2) = ptG2(2) End If Set lineBG = acadDoc.ModelSpace.AddLine(ptB, ptG) 'now find ptL, do lineAL r = distance(ptD, ptG) Set circK = acadDoc.ModelSpace.AddCircle(ptD, r) intpts = lineAD.IntersectWith(circK, acExtendThisEntity) Call intpts_eval(intpts) 'going to take the lesser y value If ptG1(1) > ptG2(1) Then ptG1(0) = ptG2(0) ptG1(1) = ptG2(1) ptG1(2) = ptG2(2) End If ptL(0) = ptG1(0) ptL(1) = ptG1(1) ptL(2) = ptG1(2) Set lineAL = acadDoc.ModelSpace.AddLine(ptA, ptL) 'ptG1 is same as ptL End Sub Sub pr2_pr1_sub(ptA() As Double, ptB() As Double) 'just the bare necessities - no drawing - calculate vertex Dim circD As AcadCircle, circE As AcadCircle Dim r As Double r = distance(ptA, ptB) Set circD = acadDoc.ModelSpace.AddCircle(ptA, r) r = distance(ptB, ptA) Set circE = acadDoc.ModelSpace.AddCircle(ptB, r) Dim intpts As Variant intpts = circD.IntersectWith(circE, acExtendNone) Call intpts_eval(intpts) 'going to take positive y value 'this is how i am passing back found vertex If ptG2(1) > ptG1(1) Then ptG1(0) = ptG2(0) ptG1(1) = ptG2(1) ptG1(2) = ptG2(2) End If circD.Delete circE.Delete End Sub
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
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 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