Thursday, February 03, 2005
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.
Comments:
<< Home
No need to iterate thru the layer collection in your helper functions. Just attempt to set a reference to the layer you are checking for and then check for an error
Public Function LayerExists(strLay As String) As Boolean
Dim oLayer As AcadLayer
On Error Resume Next
Set oLayer = ThisDrawing.Layers.Item(strLay)
If Err <> 0 Then
LayerExists = False
Else
LayerExists = True
End If
End Function
Public Function LayerExists(strLay As String) As Boolean
Dim oLayer As AcadLayer
On Error Resume Next
Set oLayer = ThisDrawing.Layers.Item(strLay)
If Err <> 0 Then
LayerExists = False
Else
LayerExists = True
End If
End Function
# posted by 
: 7:19 PM
: 7:19 PM
I was looking for some AutoCAD training and found this new site for
auto cad 2002 training along with your site. Have you seen this one yet?
Post a Comment
auto cad 2002 training along with your site. Have you seen this one yet?
<< Home
