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:

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


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.

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.

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.

This page is powered by Blogger. Isn't yours?

vba, acad vba, cad vba, cad, visual basic, visual basic for applications, autocad vba, acad vba, training, vba training, cad training, acad training, autocad training, autocad vba training, bom, bill of material, meta-data, meta data, metadata, property data, data, inventor properties, document management, document, management,technical support resource for users of Autodesk Mechanical CAD Software including Autodesk Inventor & Mechanical Desktop inventor, autodeskinventor, inventor 2, inventor 3, inventor 4, inventor 5, inventor 6, inventor7, inventor 8, inventor 9, inventor 10, autodesk inventor, autodesk inventor2, autodesk inventor 3, autodesk inventor 4, autodesk inventor 5, autodeskinventor 6, autodesk inventor 7, autodesk inventor 8, autodesk inventor9, autodesk inventor 10, inventor r, inventor r2, inventor r3, inventor r4, inventor r5, inventor r6, inventor r7, inventor r8, inventor r9, inventorr10, autodesk inventor, autodesk inventor r2, autodesk inventor r3, autodeskinventor r4, autodesk inventor r5, autodesk inventor r6, autodesk inventorr7, autodesk inventor r8, autodesk inventor r9, autodesk inventor r10,inventor series, autodesk inventor series, inventor series 5, inventorseries R5, autodesk inventor series 5, autodesk inventor series r5, inventorseries 6, inventor series R6, autodesk inventor series 6, autodesk inventorseries r6, inventor autodesk, autodesk inventor download, autodesk inventortutorial, autodesk inventor help, autodesk inventor faq, autodesk inventortips, autodesk inventor routines, autodesk inventor support, autodesk inventor, inventor download, inventor tutorial, inventor help, inventorfaq, inventor tips, inventor routines, inventor support, inventor, inventor help line, help for inventor, inventortraining, autodesk inventor training, mdt, mdt 4, mdt 5,mdt 6, mdt 7, mdt 8, mdt4, mdt5, mdt6, mdt7, mdt8, mdt 2000, mdt 2002,mdt r4, mdt r5, mdt r6, mdt r2000, mdt r2002, mechanical desktop, mechanicaldesktop 4, mechanical desktop 5, mechanical desktop 6, mechanical desktop7, mechanical desktop 2000, mechanical desktop 2002, autodesk, autodesk auto cad, autodesk inc,training, education, auto cad support, autocad support, mcad, autocad mechanical,mechanical, autocad mechanical 6, autocad mechanical 7, autocad mechanical8, autocad mechanical 9, autocad mechanical r6, autocad mechanical r7,autocad mechanical r8, autocad mechanical r9, support, help, tips, routines, reseller, mech, cad, acad, technical, ontario, canada, f.a.q.,faq, answers, resource, barrie, autolisp, auto lisp, autocad, auto cad, autocad desktop, auto cad desktop, autocad inventor, auto cadinventor, powerpack, MAI, desktop, cad software, autocad lt, auto cad lt,cad cam, cad design, cad job, job cad, autocad lisp, auto cad lisp, 3dcad software, 3d cad, free, free cad software, service pack, render, system, computer, aided, drafting, design, manufacturing, modeling, solidmodeling, solid modelling