### Thursday, February 10, 2005

## Inserting Point Data into AutoCAD

Platform: AutoCAD 2004

Download: InsertPointData.zip

Many times throughout my career I've been required to insert point data into AutoCAD. I've dealt with raw DXF data; reverse engineered the extremely old DR2 file format from 2D Catia; teach point data from industrial robots and most recently 2D point data from an Excel chart. All of these require the same thing, take 2D or 3D points consisting of X, Y and possibly Z coordinates and place them in a CAD file. With vanilla AutoCAD, this is an extremely time consuming and error prone manual task; with a bit of programming it takes seconds.

I'll show two methods of bringing in 2D data, as points and as a lightweight polyline. The sample data I'll be using is tab separated, but you can easily change the code to work with any delimiter character. With both routines, I have hard coded the path to "C:\", either place the "pointdata.txt" file here or modify the path as you require.

Let's look at inserting the data as AutoCAD point objects. First, we load the file into a string variable. Using the Split command, the data is broken down into rows; then it's a matter of looping through the rows in the "ptArray" array and splitting each value into the "pt" array as Variant/Strings. AutoCAD will only accept point data as Variant/Doubles so we have to type cast the string data into the "point" array and then add the point to model space.

Public Sub Insert2DPointDataAsPoints()

On Error GoTo ErrorHandler

Dim oPoint As AcadPoint

Dim pt As Variant

Dim point(0 To 2) As Double

Dim ptArray As Variant

Dim fileNumber As Long

Dim strFile As String

Dim i As Long

' Open the text file and store it in strFile

fileNumber = FreeFile

Open "C:\pointdata.txt" For Binary Access Read As #fileNumber

strFile = String(LOF(fileNumber), " ")

If Not Len(strFile) = 0 Then Get #fileNumber, , strFile

Close #fileNumber

' Make sure we have some data to work with

' Also checks to see if user cancelled the dialog

If Len(Trim(strFile)) = 0 Then GoTo ErrorHandler

' Split the file into rows

ptArray = Split(strFile, vbCrLf)

For i = 0 To UBound(ptArray)

' Set the point

pt = Split(ptArray(i), vbTab)

' Convert the string data to doubles

point(0) = CDbl(pt(0))

point(1) = CDbl(pt(1))

' Add the point to Modelspace

Set oPoint = ThisDrawing.ModelSpace.AddPoint(point)

Next i

' Clean up

Set oPoint = Nothing

If IsDimArray(pt) Then Erase pt

If IsDimArray(point) Then Erase point

If IsDimArray(ptArray) Then Erase ptArray

Exit Sub

ErrorHandler:

Set oPoint = Nothing

If IsDimArray(pt) Then Erase pt

If IsDimArray(point) Then Erase point

If IsDimArray(ptArray) Then Erase ptArray

End Sub

Adding a lightweight polyline isn't that different. Instead of breaking down the string data into doubles, we dimension one large array for all the 2D data "points" and use a counter "cnt" to fill in the values with our loop. Once all the data is loaded into the point array, the lightweight polyline is added to Modelspace.

Public Sub Insert2DPointDataAsLWPolyline()

On Error GoTo ErrorHandler

Dim oLWPline As AcadLWPolyline

Dim pt As Variant

Dim points() As Double

Dim ptArray As Variant

Dim fileNumber As Long

Dim strFile As String

Dim i As Long

Dim cnt As Long

' Open the text file and store it in strFile

fileNumber = FreeFile

Open "C:\pointdata.txt" For Binary Access Read As #fileNumber

strFile = String(LOF(fileNumber), " ")

If Not Len(strFile) = 0 Then Get #fileNumber, , strFile

Close #fileNumber

' Make sure we have some data to work with

' Also checks to see if user cancelled the dialog

If Len(Trim(strFile)) = 0 Then GoTo ErrorHandler

' Split the file into rows

ptArray = Split(strFile, vbCrLf)

' Resize the points array for the lightweight polyline

ReDim points((UBound(ptArray) * 2) + 1)

' Set the counter

cnt = 0

For i = 0 To UBound(ptArray)

' Set the point

pt = Split(ptArray(i), vbTab)

' Convert the string data to doubles

points(cnt) = CDbl(pt(0))

points(cnt + 1) = CDbl(pt(1))

cnt = cnt + 2

Next i

' Add the Light Weight Polyline to Modelspace

Set oLWPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)

' Clean up

Set oLWPline = Nothing

If IsDimArray(pt) Then Erase pt

If IsDimArray(points) Then Erase points

If IsDimArray(ptArray) Then Erase ptArray

Exit Sub

ErrorHandler:

Set oLWPline = Nothing

If IsDimArray(pt) Then Erase pt

If IsDimArray(points) Then Erase points

If IsDimArray(ptArray) Then Erase ptArray

End Sub

Before I forget again, add the helper routine "IsDimArray" used to clean up the arrays that were used.

Public Function IsDimArray(arr As Variant) As Boolean

On Error GoTo ErrorHandler

Dim i As Long

i = UBound(arr)

If Not i = -1 Then IsDimArray = True

Exit Function

ErrorHandler:

IsDimArray = False

End Function

Changing these routines to insert 3D data is as simple as splitting the point data into 3 doubles (for the Z coordinate) or using a polyline instead of a lightweight polyline. If you have any trouble with your own data, let me know; I'd be happy to lend a hand. A few other things that should be included for a fully useful routine:

Download: InsertPointData.zip

Many times throughout my career I've been required to insert point data into AutoCAD. I've dealt with raw DXF data; reverse engineered the extremely old DR2 file format from 2D Catia; teach point data from industrial robots and most recently 2D point data from an Excel chart. All of these require the same thing, take 2D or 3D points consisting of X, Y and possibly Z coordinates and place them in a CAD file. With vanilla AutoCAD, this is an extremely time consuming and error prone manual task; with a bit of programming it takes seconds.

I'll show two methods of bringing in 2D data, as points and as a lightweight polyline. The sample data I'll be using is tab separated, but you can easily change the code to work with any delimiter character. With both routines, I have hard coded the path to "C:\", either place the "pointdata.txt" file here or modify the path as you require.

Let's look at inserting the data as AutoCAD point objects. First, we load the file into a string variable. Using the Split command, the data is broken down into rows; then it's a matter of looping through the rows in the "ptArray" array and splitting each value into the "pt" array as Variant/Strings. AutoCAD will only accept point data as Variant/Doubles so we have to type cast the string data into the "point" array and then add the point to model space.

Public Sub Insert2DPointDataAsPoints()

On Error GoTo ErrorHandler

Dim oPoint As AcadPoint

Dim pt As Variant

Dim point(0 To 2) As Double

Dim ptArray As Variant

Dim fileNumber As Long

Dim strFile As String

Dim i As Long

' Open the text file and store it in strFile

fileNumber = FreeFile

Open "C:\pointdata.txt" For Binary Access Read As #fileNumber

strFile = String(LOF(fileNumber), " ")

If Not Len(strFile) = 0 Then Get #fileNumber, , strFile

Close #fileNumber

' Make sure we have some data to work with

' Also checks to see if user cancelled the dialog

If Len(Trim(strFile)) = 0 Then GoTo ErrorHandler

' Split the file into rows

ptArray = Split(strFile, vbCrLf)

For i = 0 To UBound(ptArray)

' Set the point

pt = Split(ptArray(i), vbTab)

' Convert the string data to doubles

point(0) = CDbl(pt(0))

point(1) = CDbl(pt(1))

' Add the point to Modelspace

Set oPoint = ThisDrawing.ModelSpace.AddPoint(point)

Next i

' Clean up

Set oPoint = Nothing

If IsDimArray(pt) Then Erase pt

If IsDimArray(point) Then Erase point

If IsDimArray(ptArray) Then Erase ptArray

Exit Sub

ErrorHandler:

Set oPoint = Nothing

If IsDimArray(pt) Then Erase pt

If IsDimArray(point) Then Erase point

If IsDimArray(ptArray) Then Erase ptArray

End Sub

Adding a lightweight polyline isn't that different. Instead of breaking down the string data into doubles, we dimension one large array for all the 2D data "points" and use a counter "cnt" to fill in the values with our loop. Once all the data is loaded into the point array, the lightweight polyline is added to Modelspace.

Public Sub Insert2DPointDataAsLWPolyline()

On Error GoTo ErrorHandler

Dim oLWPline As AcadLWPolyline

Dim pt As Variant

Dim points() As Double

Dim ptArray As Variant

Dim fileNumber As Long

Dim strFile As String

Dim i As Long

Dim cnt As Long

' Open the text file and store it in strFile

fileNumber = FreeFile

Open "C:\pointdata.txt" For Binary Access Read As #fileNumber

strFile = String(LOF(fileNumber), " ")

If Not Len(strFile) = 0 Then Get #fileNumber, , strFile

Close #fileNumber

' Make sure we have some data to work with

' Also checks to see if user cancelled the dialog

If Len(Trim(strFile)) = 0 Then GoTo ErrorHandler

' Split the file into rows

ptArray = Split(strFile, vbCrLf)

' Resize the points array for the lightweight polyline

ReDim points((UBound(ptArray) * 2) + 1)

' Set the counter

cnt = 0

For i = 0 To UBound(ptArray)

' Set the point

pt = Split(ptArray(i), vbTab)

' Convert the string data to doubles

points(cnt) = CDbl(pt(0))

points(cnt + 1) = CDbl(pt(1))

cnt = cnt + 2

Next i

' Add the Light Weight Polyline to Modelspace

Set oLWPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)

' Clean up

Set oLWPline = Nothing

If IsDimArray(pt) Then Erase pt

If IsDimArray(points) Then Erase points

If IsDimArray(ptArray) Then Erase ptArray

Exit Sub

ErrorHandler:

Set oLWPline = Nothing

If IsDimArray(pt) Then Erase pt

If IsDimArray(points) Then Erase points

If IsDimArray(ptArray) Then Erase ptArray

End Sub

Before I forget again, add the helper routine "IsDimArray" used to clean up the arrays that were used.

Public Function IsDimArray(arr As Variant) As Boolean

On Error GoTo ErrorHandler

Dim i As Long

i = UBound(arr)

If Not i = -1 Then IsDimArray = True

Exit Function

ErrorHandler:

IsDimArray = False

End Function

Changing these routines to insert 3D data is as simple as splitting the point data into 3 doubles (for the Z coordinate) or using a polyline instead of a lightweight polyline. If you have any trouble with your own data, let me know; I'd be happy to lend a hand. A few other things that should be included for a fully useful routine:

- Watch for blank lines in the point data
- Check all the data to be sure it is numeric before adding the point
- Add code to make sure the point data file exists before trying to open it

### Sunday, February 06, 2005

## Drawing the Golden Ratio

Platform: AutoCAD 2004

Download: GoldenRatio.zip

The Golden Ratio has always fascinated me. I'm no math wizard but the Golden Ration (also known as Phi) has a tendency to turn up in a great number of places: the spiral of a sea shell, the swirl of milk in coffee, clouds, crop circles, and the list goes on. I highly recommend a movie directed by Darren Aronofsky, a very odd but interesting movie from 1998 entitled Pi (IMDB link) that touches on Phi and Fibonacci sequences.

Fibonacci sequences occur when any term after the first two can be found by summing the two previous terms. Here's an example: 1, 1, 2, 3, 5, 8, 13, ...

I'll point you to the two links below for full details on Phi and Fibonacci sequences:

We can calculate a Fibonacci sequence with this function:

Public Function Fibonacci(ByVal lngNumber As Long) As Long

On Error GoTo ErrorHandler

If lngNumber <= 1 Then ' ignore negatives

Fibonacci = 0

ElseIf lngNumber = 2 Then

Fibonacci = 1

Else ' return the fibonacci number

Fibonacci = Fibonacci(lngNumber - 1) + Fibonacci(lngNumber - 2)

End If

Exit Function

ErrorHandler:

End Function

The trickiest part of the routine was resetting the start point for the arc as it moves every iteration of the loop. First, Add a constant for PI, then add the routine below.

Public Const PI = 3.14159265358979 ' 3.1415926535897932384626433832795 or atn(1.0)*4

Public Sub AddGoldenRatio(lngQuads As Long)

' Draw the golden ratio (PHI) starting at 0,0 and spiral out

On Error GoTo ErrorHandler

Dim objArc As AcadArc

Dim pt1(0 To 2) As Double

Dim lngCorner As Long ' Start corner: 0=SW, 1=SE, 2=NE, 3=NW

Dim dblLength As Double ' Length of a side.

Dim dblLast As Double ' Last Length

Dim dblAngleStart As Double ' Start angle of arc

Dim dblAngleEnd As Double ' End angle of arc

Dim i As Long

lngCorner = 0 ' Draw first square from 0,0

dblLength = 1 ' Start with a 1x1 square

pt1(0) = 0#: pt1(1) = 0# ' Center point of arc

dblAngleStart = 0# ' Start at 0 deg

dblAngleEnd = 90# * (PI / 180#) ' Start at 90 deg (converted to radians)

' Start at 4 to skip duplicates in Fibonacci sequence

' Add 3 to compensate

For i = 4 To lngQuads + 3

' Add arc to modelspace

Set objArc = ThisDrawing.ModelSpace.AddArc(pt1, dblLength, dblAngleStart, dblAngleEnd)

' Update angles

dblAngleStart = dblAngleEnd

dblAngleEnd = dblAngleEnd + 90# * (PI / 180#)

' Set lengths

dblLast = dblLength

dblLength = Fibonacci(i)

' Move our startpoint

Select Case lngCorner

Case 0

pt1(0) = pt1(0)

pt1(1) = pt1(1) - (dblLength - dblLast)

Case 1

pt1(0) = pt1(0) + (dblLength - dblLast)

pt1(1) = pt1(1)

Case 2

pt1(0) = pt1(0)

pt1(1) = pt1(1) + (dblLength - dblLast)

Case 3

pt1(0) = pt1(0) - (dblLength - dblLast)

pt1(1) = pt1(1)

End Select

' Incerement our corner

lngCorner = lngCorner + 1

If lngCorner = 4 Then lngCorner = 0

Next i

' Clean up

Set objArc = Nothing

If IsDimArray(pt1) Then Erase pt1

Exit Sub

ErrorHandler:

Set objArc = Nothing

If IsDimArray(pt1) Then Erase pt1

End Sub

Update: I forgot to add the IsDimArray function. You can thank Jimmy Bergmark for catching my mistake. The IsDimArray function checks to see if an array has been dimensioned yet and reurns a boolean.

Public Function IsDimArray(arr As Variant) As Boolean

On Error GoTo ErrorHandler

Dim i As Long

i = UBound(arr)

If Not i = -1 Then IsDimArray = True

Exit Function

ErrorHandler:

IsDimArray = False

End Function

Not sure if you can find any technical use for this, but I hope I have peaked you interest into this interesting corner of mathematics. To call the routine add a sub like below:

Private Sub DrawGoldenRatio()

Call AddGoldenRatio(8)

End Sub

Download: GoldenRatio.zip

The Golden Ratio has always fascinated me. I'm no math wizard but the Golden Ration (also known as Phi) has a tendency to turn up in a great number of places: the spiral of a sea shell, the swirl of milk in coffee, clouds, crop circles, and the list goes on. I highly recommend a movie directed by Darren Aronofsky, a very odd but interesting movie from 1998 entitled Pi (IMDB link) that touches on Phi and Fibonacci sequences.

Fibonacci sequences occur when any term after the first two can be found by summing the two previous terms. Here's an example: 1, 1, 2, 3, 5, 8, 13, ...

I'll point you to the two links below for full details on Phi and Fibonacci sequences:

We can calculate a Fibonacci sequence with this function:

Public Function Fibonacci(ByVal lngNumber As Long) As Long

On Error GoTo ErrorHandler

If lngNumber <= 1 Then ' ignore negatives

Fibonacci = 0

ElseIf lngNumber = 2 Then

Fibonacci = 1

Else ' return the fibonacci number

Fibonacci = Fibonacci(lngNumber - 1) + Fibonacci(lngNumber - 2)

End If

Exit Function

ErrorHandler:

End Function

The trickiest part of the routine was resetting the start point for the arc as it moves every iteration of the loop. First, Add a constant for PI, then add the routine below.

Public Const PI = 3.14159265358979 ' 3.1415926535897932384626433832795 or atn(1.0)*4

Public Sub AddGoldenRatio(lngQuads As Long)

' Draw the golden ratio (PHI) starting at 0,0 and spiral out

On Error GoTo ErrorHandler

Dim objArc As AcadArc

Dim pt1(0 To 2) As Double

Dim lngCorner As Long ' Start corner: 0=SW, 1=SE, 2=NE, 3=NW

Dim dblLength As Double ' Length of a side.

Dim dblLast As Double ' Last Length

Dim dblAngleStart As Double ' Start angle of arc

Dim dblAngleEnd As Double ' End angle of arc

Dim i As Long

lngCorner = 0 ' Draw first square from 0,0

dblLength = 1 ' Start with a 1x1 square

pt1(0) = 0#: pt1(1) = 0# ' Center point of arc

dblAngleStart = 0# ' Start at 0 deg

dblAngleEnd = 90# * (PI / 180#) ' Start at 90 deg (converted to radians)

' Start at 4 to skip duplicates in Fibonacci sequence

' Add 3 to compensate

For i = 4 To lngQuads + 3

' Add arc to modelspace

Set objArc = ThisDrawing.ModelSpace.AddArc(pt1, dblLength, dblAngleStart, dblAngleEnd)

' Update angles

dblAngleStart = dblAngleEnd

dblAngleEnd = dblAngleEnd + 90# * (PI / 180#)

' Set lengths

dblLast = dblLength

dblLength = Fibonacci(i)

' Move our startpoint

Select Case lngCorner

Case 0

pt1(0) = pt1(0)

pt1(1) = pt1(1) - (dblLength - dblLast)

Case 1

pt1(0) = pt1(0) + (dblLength - dblLast)

pt1(1) = pt1(1)

Case 2

pt1(0) = pt1(0)

pt1(1) = pt1(1) + (dblLength - dblLast)

Case 3

pt1(0) = pt1(0) - (dblLength - dblLast)

pt1(1) = pt1(1)

End Select

' Incerement our corner

lngCorner = lngCorner + 1

If lngCorner = 4 Then lngCorner = 0

Next i

' Clean up

Set objArc = Nothing

If IsDimArray(pt1) Then Erase pt1

Exit Sub

ErrorHandler:

Set objArc = Nothing

If IsDimArray(pt1) Then Erase pt1

End Sub

Update: I forgot to add the IsDimArray function. You can thank Jimmy Bergmark for catching my mistake. The IsDimArray function checks to see if an array has been dimensioned yet and reurns a boolean.

Public Function IsDimArray(arr As Variant) As Boolean

On Error GoTo ErrorHandler

Dim i As Long

i = UBound(arr)

If Not i = -1 Then IsDimArray = True

Exit Function

ErrorHandler:

IsDimArray = False

End Function

Not sure if you can find any technical use for this, but I hope I have peaked you interest into this interesting corner of mathematics. To call the routine add a sub like below:

Private Sub DrawGoldenRatio()

Call AddGoldenRatio(8)

End Sub

### Thursday, February 03, 2005

## The six laws of new software

This is an article every programmer should read, especially those just starting to enter the world of software development:

It's common sense for those of us who have been around long enough to learn the hard way; hindsight is 20/20. Always a good idea to remember the real reason we're writing code, to help the end users.

It's common sense for those of us who have been around long enough to learn the hard way; hindsight is 20/20. Always a good idea to remember the real reason we're writing code, to help the end users.

## I hate CAD standards. Part 2

Platform: AutoCAD 2004

Download: IHateCADStandards.zip

Continuing from Part 1, we'll start by setting our units.

Public Function setUnits() As Boolean

' Set base drawing units

On Error GoTo ErrorHandler

' Set system variables

With ThisDrawing

.SetVariable "LUNITS", 2 ' Sets linear units to Decimal

.SetVariable "LUPREC", 3 ' Sets the # of decimal places displayed for all read-only linear units

.SetVariable "AUNITS", 0 ' Sets units for angles to Decimal degrees

.SetVariable "AUPREC", 3 ' Sets the number of decimal places for all read-only angular units

.SetVariable "MEASUREMENT", 0 'Sets units as imperial or metric for the current drawing only

.SetVariable "ANGDIR", 0 'Sets the direction of positive angles. Set to Counterclockwise

.SetVariable "ANGBASE", 0# ' Sets the base angle to 0 with respect to the current UCS.

.SetVariable "INSUNITS", 1 ' Specifies units for drag & dropped blocks or images. Set to Inches

End With

setUnits = True

Exit Function

ErrorHandler:

' Insert error handler here

End Function

No real magic here, we're just setting a few system variables. Call the above routine with the following line:

If Not setUnits Then GoTo ErrorHandler

Now we can focus on layer modification. Layers can get a bit tricky so we have to be careful what we do. I found out the hard way that you can set a layer's colour to black and it will be invisible if your workspace background is black. Note to self: make a routine that loops through all layers and sets their colours to black to annoy coworkers. We'll also create a few helper routines to set a layer current, check if a layer already exists and if it is locked.

Public Function CreateLayer(strLay As String, _

strLineType As String, _

Optional setColor As Boolean = False, _

Optional lngRed As Long, _

Optional lngGreen As Long, _

Optional lngBlue As Long, _

Optional lyrLineWeight As ACAD_LWEIGHT = acLnWtByLayer, _

Optional booPlottable As Boolean = True, _

Optional booLock As Boolean = False, _

Optional booFreeze As Boolean = False, _

Optional booLayerOn As Boolean = True) As Boolean

On Error GoTo ErrorHandler

Dim newLayer As AcadLayer

Dim objLineType As AcadLineType

Dim objColor As AcadAcCmColor

Dim booFound As Boolean

Set newLayer = ThisDrawing.Layers.Add(strLay)

With newLayer

If setColor Then

Set objColor = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")

If (lngRed = 0 And lngGreen = 0 And lngBlue = 0) Or _

(lngRed = 255 And lngGreen = 255 And lngBlue = 255) Then

objColor.ColorIndex = acWhite

Else

Call objColor.SetRGB(lngRed, lngGreen, lngBlue)

End If

.TrueColor = objColor

End If

.Lineweight = lyrLineWeight

.Plottable = booPlottable

.Lock = booLock

If Not StrComp(ThisDrawing.ActiveLayer.Name, strLay, vbTextCompare) = 0 Then .Freeze = booFreeze

.LayerOn = booLayerOn

For Each objLineType In ThisDrawing.Linetypes

If StrComp(objLineType.Name, strLineType, vbTextCompare) = 0 Then

booFound = True

Exit For

End If

Next

If Not booFound Then ThisDrawing.Linetypes.Load strLineType, "acadiso.lin"

.Linetype = strLineType

End With

Set newLayer = Nothing

Set objLineType = Nothing

If setColor Then Set objColor = Nothing

CreateLayer = True

Exit Function

ErrorHandler:

Set newLayer = Nothing

Set objLineType = Nothing

If setColor Then Set objColor = Nothing

End Function

It seems more complicated than it should be (and it might be) but it works well. If you only use the base 16 or 255 colours, you can rip out the entire "setColor" section and just pass the routine a colour code. Call the above routine with the following line:

If Not CreateLayer("Building-Columns", _

"Continuous", _

True, _

255, 191, 0, _

acLnWtByLwDefault, _

True, False, False, True) Then GoTo ErrorHandler

If Not CreateLayer("Building", _

"Continuous", _

True, _

204, 51, 0, _

acLnWtByLwDefault, _

True, False, False, True) Then GoTo ErrorHandler

If Not CreateLayer("Building-Columns", _

"Continuous", _

True, _

255, 191, 0, _

acLnWtByLwDefault, _

True, False, False, True) Then GoTo ErrorHandler

If Not CreateLayer("Building-Column-Lines", _

"Continuous", _

True, _

102, 204, 0, _

acLnWtByLwDefault, _

True, False, False, True) Then GoTo ErrorHandler

If Not CreateLayer("Building-Drains", _

"Continuous", _

True, _

132, 132, 132, _

acLnWtByLwDefault, _

True, False, False, True) Then GoTo ErrorHandler

Be sure to use the helper routines I mentioned earlier whenever you need to create or modify a layer.

Public Function LayerExists(strLay As String) As Boolean

On Error GoTo ErrorHandler

Dim oLayers As AcadLayers

Dim oLayer As AcadLayer

Set oLayers = ThisDrawing.Layers

For Each oLayer In oLayers

If StrComp(oLayer.Name, strLay, vbTextCompare) = 0 Then

LayerExists = True

Exit For

End If

Next

Set oLayers = Nothing

Set oLayer = Nothing

Exit Function

ErrorHandler:

Set oLayers = Nothing

Set oLayer = Nothing

End Function

Public Function LayerLocked(strLay As String) As Boolean

On Error GoTo ErrorHandler

Dim oLayers As AcadLayers

Dim oLayer As AcadLayer

Set oLayers = ThisDrawing.Layers

For Each oLayer In oLayers

If StrComp(oLayer.Name, strLay, vbTextCompare) = 0 Then

If oLayer.Lock = True Then LayerLocked = True

Exit For

End If

Next

Set oLayers = Nothing

Set oLayer = Nothing

Exit Function

ErrorHandler:

Set oLayers = Nothing

Set oLayer = Nothing

End Function

One final pitfall to watch out for, don't try to lock or delete the current layer.

Download: IHateCADStandards.zip

Continuing from Part 1, we'll start by setting our units.

Public Function setUnits() As Boolean

' Set base drawing units

On Error GoTo ErrorHandler

' Set system variables

With ThisDrawing

.SetVariable "LUNITS", 2 ' Sets linear units to Decimal

.SetVariable "LUPREC", 3 ' Sets the # of decimal places displayed for all read-only linear units

.SetVariable "AUNITS", 0 ' Sets units for angles to Decimal degrees

.SetVariable "AUPREC", 3 ' Sets the number of decimal places for all read-only angular units

.SetVariable "MEASUREMENT", 0 'Sets units as imperial or metric for the current drawing only

.SetVariable "ANGDIR", 0 'Sets the direction of positive angles. Set to Counterclockwise

.SetVariable "ANGBASE", 0# ' Sets the base angle to 0 with respect to the current UCS.

.SetVariable "INSUNITS", 1 ' Specifies units for drag & dropped blocks or images. Set to Inches

End With

setUnits = True

Exit Function

ErrorHandler:

' Insert error handler here

End Function

No real magic here, we're just setting a few system variables. Call the above routine with the following line:

If Not setUnits Then GoTo ErrorHandler

Now we can focus on layer modification. Layers can get a bit tricky so we have to be careful what we do. I found out the hard way that you can set a layer's colour to black and it will be invisible if your workspace background is black. Note to self: make a routine that loops through all layers and sets their colours to black to annoy coworkers. We'll also create a few helper routines to set a layer current, check if a layer already exists and if it is locked.

Public Function CreateLayer(strLay As String, _

strLineType As String, _

Optional setColor As Boolean = False, _

Optional lngRed As Long, _

Optional lngGreen As Long, _

Optional lngBlue As Long, _

Optional lyrLineWeight As ACAD_LWEIGHT = acLnWtByLayer, _

Optional booPlottable As Boolean = True, _

Optional booLock As Boolean = False, _

Optional booFreeze As Boolean = False, _

Optional booLayerOn As Boolean = True) As Boolean

On Error GoTo ErrorHandler

Dim newLayer As AcadLayer

Dim objLineType As AcadLineType

Dim objColor As AcadAcCmColor

Dim booFound As Boolean

Set newLayer = ThisDrawing.Layers.Add(strLay)

With newLayer

If setColor Then

Set objColor = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")

If (lngRed = 0 And lngGreen = 0 And lngBlue = 0) Or _

(lngRed = 255 And lngGreen = 255 And lngBlue = 255) Then

objColor.ColorIndex = acWhite

Else

Call objColor.SetRGB(lngRed, lngGreen, lngBlue)

End If

.TrueColor = objColor

End If

.Lineweight = lyrLineWeight

.Plottable = booPlottable

.Lock = booLock

If Not StrComp(ThisDrawing.ActiveLayer.Name, strLay, vbTextCompare) = 0 Then .Freeze = booFreeze

.LayerOn = booLayerOn

For Each objLineType In ThisDrawing.Linetypes

If StrComp(objLineType.Name, strLineType, vbTextCompare) = 0 Then

booFound = True

Exit For

End If

Next

If Not booFound Then ThisDrawing.Linetypes.Load strLineType, "acadiso.lin"

.Linetype = strLineType

End With

Set newLayer = Nothing

Set objLineType = Nothing

If setColor Then Set objColor = Nothing

CreateLayer = True

Exit Function

ErrorHandler:

Set newLayer = Nothing

Set objLineType = Nothing

If setColor Then Set objColor = Nothing

End Function

It seems more complicated than it should be (and it might be) but it works well. If you only use the base 16 or 255 colours, you can rip out the entire "setColor" section and just pass the routine a colour code. Call the above routine with the following line:

If Not CreateLayer("Building-Columns", _

"Continuous", _

True, _

255, 191, 0, _

acLnWtByLwDefault, _

True, False, False, True) Then GoTo ErrorHandler

If Not CreateLayer("Building", _

"Continuous", _

True, _

204, 51, 0, _

acLnWtByLwDefault, _

True, False, False, True) Then GoTo ErrorHandler

If Not CreateLayer("Building-Columns", _

"Continuous", _

True, _

255, 191, 0, _

acLnWtByLwDefault, _

True, False, False, True) Then GoTo ErrorHandler

If Not CreateLayer("Building-Column-Lines", _

"Continuous", _

True, _

102, 204, 0, _

acLnWtByLwDefault, _

True, False, False, True) Then GoTo ErrorHandler

If Not CreateLayer("Building-Drains", _

"Continuous", _

True, _

132, 132, 132, _

acLnWtByLwDefault, _

True, False, False, True) Then GoTo ErrorHandler

Be sure to use the helper routines I mentioned earlier whenever you need to create or modify a layer.

Public Function LayerExists(strLay As String) As Boolean

On Error GoTo ErrorHandler

Dim oLayers As AcadLayers

Dim oLayer As AcadLayer

Set oLayers = ThisDrawing.Layers

For Each oLayer In oLayers

If StrComp(oLayer.Name, strLay, vbTextCompare) = 0 Then

LayerExists = True

Exit For

End If

Next

Set oLayers = Nothing

Set oLayer = Nothing

Exit Function

ErrorHandler:

Set oLayers = Nothing

Set oLayer = Nothing

End Function

Public Function LayerLocked(strLay As String) As Boolean

On Error GoTo ErrorHandler

Dim oLayers As AcadLayers

Dim oLayer As AcadLayer

Set oLayers = ThisDrawing.Layers

For Each oLayer In oLayers

If StrComp(oLayer.Name, strLay, vbTextCompare) = 0 Then

If oLayer.Lock = True Then LayerLocked = True

Exit For

End If

Next

Set oLayers = Nothing

Set oLayer = Nothing

Exit Function

ErrorHandler:

Set oLayers = Nothing

Set oLayer = Nothing

End Function

One final pitfall to watch out for, don't try to lock or delete the current layer.

### Tuesday, February 01, 2005

## I hate CAD standards. Part 1

Platform: AutoCAD 2004

Download: IHateCADStandards.zip

I have a confession; I hate CAD standards. It's not that I don't like following rules, I hate all the steps involved in having to add the standards.

I deal with a lot of third party drawings, about 95% or more of the drawings I work in come from a customer or consultant so having a perfect template to start from isn't a luxury I can work with. Now before anyone says “but Autodesk has given us many tools to enforce standards”, I know…but I'm very lazy when it comes to adding standards, like I mentioned, I hate them.

So, instead of complaining, I've made a single-click solution. I can now add all of my text styles, dimension styles, layers and units with a single click of a button. If you find yourself in the same situation, read on for some invaluable routines.

The first routine will add a new text style with RomanS as the font and the width specified in dblWidth:

Public Function AddTextStyle(dblWidth As Double) As Boolean

On Error GoTo ErrorHandler

Dim oTextStyle As AcadTextStyle

Set oTextStyle = ThisDrawing.TextStyles.Add("MY_ROMANS")

With oTextStyle

.fontFile = "C:/Program Files/AutoCAD 2004/Fonts/romans.shx"

.Width = dblWidth

End With

ThisDrawing.ActiveTextStyle = oTextStyle

Set oTextStyle = Nothing

AddTextStyle = True

Exit Function

ErrorHandler:

Set oTextStyle = Nothing

End Function

Be sure to add in some code to confirm that "romans.shx" exists. Call the above routine with the following line:

If Not AddTextStyle(1#) Then GoTo ErrorHandler

Now that we have our required text styles added into the drawing, we can add our dimension styles. The problem with creating a dimension style is that we don't know the status of any of the variables, so we have to set EVERY variable.

Private Function createDimStyle(dblScale As Double) As Boolean

On Error GoTo ErrorHandler

' Create dimension style

Dim oDimStyle As AcadDimStyle

Dim oTextStyle As AcadTextStyle

' Set system variables

With ThisDrawing

.SetVariable "DIMCLRD", 140

.SetVariable "DIMLWD", -2

.SetVariable "DIMDLI", 0.08

.SetVariable "DIMCLRE", 140

.SetVariable "DIMLWE", -2

.SetVariable "DIMEXE", 0.08

.SetVariable "DIMEXO", 0.08

.SetVariable "DIMASZ", 0.08

.SetVariable "DIMSD1", 0

.SetVariable "DIMSD2", 0

.SetVariable "DIMSE1", 0

.SetVariable "DIMSE2", 0

.SetVariable "DIMBLK1", "."

.SetVariable "DIMBLK2", "."

.SetVariable "DIMLDRBLK", "."

.SetVariable "DIMCEN", 0

.SetVariable "DIMTIH", 1

.SetVariable "DIMTOH", 1

.SetVariable "DIMTMOVE", 0

' Confirm that my TestStyle is there before setting

For Each oTextStyle In .TextStyles

If StrComp(oTextStyle.Name, "MY_ROMANS", vbTextCompare) = 0 Then

.SetVariable "DIMTXSTY", "MY_ROMANS"

Exit For

End If

Next

.SetVariable "DIMCLRT", 120

.SetVariable "DIMTXT", 0.08

.SetVariable "DIMATFIT", 3

.SetVariable "DIMTIX", 0

.SetVariable "DIMSOXD", 0

.SetVariable "DIMUPT", 0

.SetVariable "DIMTOFL", 0

.SetVariable "DIMTAD", 0

.SetVariable "DIMJUST", 0

.SetVariable "DIMGAP", 0.08

.SetVariable "DIMLUNIT", 2

.SetVariable "DIMTFAC", 1

.SetVariable "DIMDEC", 3

.SetVariable "DIMFRAC", 0

.SetVariable "DIMDSEP", "."

.SetVariable "DIMRND", 0

.SetVariable "DIMPOST", ""

.SetVariable "DIMLFAC", 1

.SetVariable "DIMZIN", 0

.SetVariable "DIMAUNIT", 0

.SetVariable "DIMADEC", 3

.SetVariable "DIMAZIN", 0

.SetVariable "DIMALT", 0

.SetVariable "DIMTOL", 0

.SetVariable "DIMLIM", 0

.SetVariable "DIMTDEC", 3

.SetVariable "DIMTP", 0

.SetVariable "DIMTM", 0

.SetVariable "DIMTFAC", 1

.SetVariable "DIMTOLJ", 1

.SetVariable "DIMALTTD", 2

.SetVariable "DIMALTTZ", 0

' Set scale to dblScale

.SetVariable "DIMSCALE", dblScale

' Create Descon dimstyle

Set oDimStyle = .DimStyles.Add("MyDimStyle" & CStr(CLng(dblScale)))

oDimStyle.CopyFrom ThisDrawing

.ActiveDimStyle = oDimStyle

End With

Set oDimStyle = Nothing

Set oTextStyle = Nothing

createDimStyle = True

Exit Function

ErrorHandler:

Set oDimStyle = Nothing

Set oTextStyle = Nothing

End Function

Just to clarify, all we've done with the routine above is set a whole bunch of style overrides on the current dimension style and then copied our modified style into a new dimension style. Odd way of doing it, but we work with the tools we have. Call the above routine with the following line:

If Not createDimStyle(48#) Then GoTo ErrorHandler

This will create a dimension style, the way we like with a scale appropriate for a 1/4"=1'-0" PaperSpace viewport.

Check out Part 2 of this article to find out how to create layers and set the default units in your drawing.

Download: IHateCADStandards.zip

I have a confession; I hate CAD standards. It's not that I don't like following rules, I hate all the steps involved in having to add the standards.

I deal with a lot of third party drawings, about 95% or more of the drawings I work in come from a customer or consultant so having a perfect template to start from isn't a luxury I can work with. Now before anyone says “but Autodesk has given us many tools to enforce standards”, I know…but I'm very lazy when it comes to adding standards, like I mentioned, I hate them.

So, instead of complaining, I've made a single-click solution. I can now add all of my text styles, dimension styles, layers and units with a single click of a button. If you find yourself in the same situation, read on for some invaluable routines.

The first routine will add a new text style with RomanS as the font and the width specified in dblWidth:

Public Function AddTextStyle(dblWidth As Double) As Boolean

On Error GoTo ErrorHandler

Dim oTextStyle As AcadTextStyle

Set oTextStyle = ThisDrawing.TextStyles.Add("MY_ROMANS")

With oTextStyle

.fontFile = "C:/Program Files/AutoCAD 2004/Fonts/romans.shx"

.Width = dblWidth

End With

ThisDrawing.ActiveTextStyle = oTextStyle

Set oTextStyle = Nothing

AddTextStyle = True

Exit Function

ErrorHandler:

Set oTextStyle = Nothing

End Function

Be sure to add in some code to confirm that "romans.shx" exists. Call the above routine with the following line:

If Not AddTextStyle(1#) Then GoTo ErrorHandler

Now that we have our required text styles added into the drawing, we can add our dimension styles. The problem with creating a dimension style is that we don't know the status of any of the variables, so we have to set EVERY variable.

Private Function createDimStyle(dblScale As Double) As Boolean

On Error GoTo ErrorHandler

' Create dimension style

Dim oDimStyle As AcadDimStyle

Dim oTextStyle As AcadTextStyle

' Set system variables

With ThisDrawing

.SetVariable "DIMCLRD", 140

.SetVariable "DIMLWD", -2

.SetVariable "DIMDLI", 0.08

.SetVariable "DIMCLRE", 140

.SetVariable "DIMLWE", -2

.SetVariable "DIMEXE", 0.08

.SetVariable "DIMEXO", 0.08

.SetVariable "DIMASZ", 0.08

.SetVariable "DIMSD1", 0

.SetVariable "DIMSD2", 0

.SetVariable "DIMSE1", 0

.SetVariable "DIMSE2", 0

.SetVariable "DIMBLK1", "."

.SetVariable "DIMBLK2", "."

.SetVariable "DIMLDRBLK", "."

.SetVariable "DIMCEN", 0

.SetVariable "DIMTIH", 1

.SetVariable "DIMTOH", 1

.SetVariable "DIMTMOVE", 0

' Confirm that my TestStyle is there before setting

For Each oTextStyle In .TextStyles

If StrComp(oTextStyle.Name, "MY_ROMANS", vbTextCompare) = 0 Then

.SetVariable "DIMTXSTY", "MY_ROMANS"

Exit For

End If

Next

.SetVariable "DIMCLRT", 120

.SetVariable "DIMTXT", 0.08

.SetVariable "DIMATFIT", 3

.SetVariable "DIMTIX", 0

.SetVariable "DIMSOXD", 0

.SetVariable "DIMUPT", 0

.SetVariable "DIMTOFL", 0

.SetVariable "DIMTAD", 0

.SetVariable "DIMJUST", 0

.SetVariable "DIMGAP", 0.08

.SetVariable "DIMLUNIT", 2

.SetVariable "DIMTFAC", 1

.SetVariable "DIMDEC", 3

.SetVariable "DIMFRAC", 0

.SetVariable "DIMDSEP", "."

.SetVariable "DIMRND", 0

.SetVariable "DIMPOST", ""

.SetVariable "DIMLFAC", 1

.SetVariable "DIMZIN", 0

.SetVariable "DIMAUNIT", 0

.SetVariable "DIMADEC", 3

.SetVariable "DIMAZIN", 0

.SetVariable "DIMALT", 0

.SetVariable "DIMTOL", 0

.SetVariable "DIMLIM", 0

.SetVariable "DIMTDEC", 3

.SetVariable "DIMTP", 0

.SetVariable "DIMTM", 0

.SetVariable "DIMTFAC", 1

.SetVariable "DIMTOLJ", 1

.SetVariable "DIMALTTD", 2

.SetVariable "DIMALTTZ", 0

' Set scale to dblScale

.SetVariable "DIMSCALE", dblScale

' Create Descon dimstyle

Set oDimStyle = .DimStyles.Add("MyDimStyle" & CStr(CLng(dblScale)))

oDimStyle.CopyFrom ThisDrawing

.ActiveDimStyle = oDimStyle

End With

Set oDimStyle = Nothing

Set oTextStyle = Nothing

createDimStyle = True

Exit Function

ErrorHandler:

Set oDimStyle = Nothing

Set oTextStyle = Nothing

End Function

Just to clarify, all we've done with the routine above is set a whole bunch of style overrides on the current dimension style and then copied our modified style into a new dimension style. Odd way of doing it, but we work with the tools we have. Call the above routine with the following line:

If Not createDimStyle(48#) Then GoTo ErrorHandler

This will create a dimension style, the way we like with a scale appropriate for a 1/4"=1'-0" PaperSpace viewport.

Check out Part 2 of this article to find out how to create layers and set the default units in your drawing.