|
Public Sub
CenterMark()
'/I
use option explicit in all of
'/my
modules, so I MUST declare every
'/variable
I plan on using!
Dim objUtil As
AcadUtility
Dim objCurve As
AcadEntity
Dim objLayer As
AcadLayer
Dim objSpace As
AcadBlock
Dim objVert As
AcadLine
Dim objHrz As
AcadLine
Dim varCent As
Variant
Dim varPnt As
Variant
Dim varStart As
Variant
Dim varEnd As
Variant
Dim strInput As
String
Dim strPrmt As
String
Dim dblAng As
Double
Dim dblRad As
Double
Dim dblDist As
Double
Dim dblExe As
Double
'/This
is VB Designs standard Error
'/Label
and GoTo line!
On Error
GoTo Err_Control
'/Because
I will need to use the Polar Point,
'/Get
Entity methods of the utility object
'/I
can optimize my code by mapping to it one
'/Time
(mapping = binding)
Set objUtil = ThisDrawing.Utility
'/By
testing the Active space here and binding to the
'/Block
that represents it, I can create new entities
'/in
that space anywhere in my code without multiple
'/If
then testing. You did know that Model Space and
'/Paper
space are defined as blocks in the drawing,
'/Didn't
you?
If ThisDrawing.ActiveSpace
= acModelSpace Then
Set objSpace = ThisDrawing.ModelSpace
Else
Set objSpace = ThisDrawing.PaperSpace
End If
'/vbCr
means Visual Basic Carriage Return
'/This
places my prompt on a new line
strPrmt = vbCr & "Pick Circle or Arc: "
'/objCurve
is bound to whatever the user selects
'/Unless
they don't select anything (click empty
'/Space)
in which case VBA raises the error:
'/Method
GetEntity of object Utility failed
'/In
that case code execution jumps to the label
'/Err_Control.
objUtil.GetEntity objCurve, varPnt, strPrmt
'/I
need to varify that the user selected a Curve
'/Type
entity, specifically an Arc or Circle. The
'/TypeOf
returns the CLASS NAME as defined in the
'/Type
Library - handy isn't it?
If TypeOf objCurve Is
AcadCircle Or _
TypeOf objCurve Is AcadArc
Then
'//Here
I get the Extend distance from the DIMEXE
'//System
variable, I thought that would be the
'//Best
value to use, but you could just hard code
'//A
value into this program:
'//dblExe
= 0.18
'//or
whatever value you prefere.
dblExe = CDbl(ThisDrawing.GetVariable("DIMEXE"))
'//I
am going to use the center point for the first
'//Point
argument of the polar point method
varCent = objCurve.Center
'//Polar
point needs a distance, and in this case
'//It
is the radius plus the extension distance
dblRad = objCurve.Radius
dblDist = dblRad + dblExe
'//This
point first <-----
+
dblAng = 180 / 180 * (Atn(1)
* 4)
'//Did
you catch that? Atn(1) * 4 = PI
'//And
degrees * 180 / PI = the degrees in radians!
varStart = objUtil.PolarPoint(varCent, dblAng, _
dblDist)
'//This
point next + ----->
varEnd = objUtil.PolarPoint(varCent, 0, dblDist)
'//See,
now I can use the block to add the line!
Set objHrz = objSpace.AddLine(varStart,
varEnd)
'//Now
we create the Vertical line
dblAng = 90 / 180 * (Atn(1)
* 4)
varStart = objUtil.PolarPoint(varCent, dblAng, _
dblDist)
dblAng = 270 / 180 * (Atn(1)
* 4)
varEnd = objUtil.PolarPoint(varCent, dblAng, _
dblDist)
Set objVert = objSpace.AddLine(varStart,
varEnd)
'//This
calls the Layer Exists function so go there
'//And
read how it determines if the layer exists.
'//By
the way, This syntax is the same as saying:
'//If
LayerExist("Center") = True Then
'//Because
Booleans have an assumed value(True/False)
'//And
the If Then Structure Means "If True Then"
If LayerExists("Center")
Then
objHrz.Layer = "Center"
objVert.Layer = "Center"
Else
Set objLayer = _
ThisDrawing.Layers.Add("Center")
'//Since
we are making the layer, we are going to set
'//It's
line type, but we need to know if the one we
'//Want
(CENTER) is loaded, so look at the
'//LineTypeLoaded
function to see how that is
'//Determined
'//Проверяем, загружен ли тип линии "CENTER",
'//если не загружен - загружаем его из файла acad.lin
If LineTypeLoaded("CENTER")
Then
objLayer.LineType = "CENTER"
Else
ThisDrawing.Linetypes.Load
_
"CENTER", "acad.lin"
objLayer.LineType = "CENTER"
End If
objHrz.Layer = "Center"
objVert.Layer = "Center"
End If
End If
'/When
you have an Error handler you MUST explicitly
'/Exit
the procedure. If you don't, the code inside
'/The
Error handler will be executed even though there
'/Has
not been an error!
Exit_Here:
Exit Sub
Err_Control:
'/Select
case in an error handler is an ideal way
'/To
determine what kind of error occurred
Select Case
Err.Number
'/This
code was designed by Jessica, and works by
'/Checking
the error number - did the method GetEntity
'/Fail...
Case -2147352567
'/Now
the question is why? Did the user press cancel?
strInput = ThisDrawing.GetVariable("LASTPROMPT")
If InStr(1,
strInput, _
"CANCEL", vbTextCompare) > 0 Then
'/////YES,
so we should just Exit
Resume Exit_Here
Else
'/////NO,
they must have missed the pick!
Resume
End If
Case Else
'///Any
other error is handled here!
MsgBox Err.Description
Resume Exit_Here
End Select
End
Sub
Public Function
LayerExists(LayerName _
As String)
As Boolean
Dim objLayer As
AcadLayer
Dim objLayers As
AcadLayers
'/This
type of function is the only real
'/Good
place for this next line
On Error
Resume Next
'/Because
we KNOW that an error could be
'/about
to occur, what error it could be
'/AND
WE ARE GOING TO USE THE ERROR TO
'/DETERMINE
THE VALUE OF THE FUNCTION
Set objLayers = ThisDrawing.Layers
Set objLayer = objLayers(LayerName)
LayerExists = (Err.Number
= 0)
'/Now
clear it!
Err.Clear
Set objLayer = Nothing
Set objLayers = Nothing
'/And
return to the calling function with
'/the
value..
End
Function
'
Проверка загрузки в чертеж типа линии с заданным именем
Public Function
LineTypeLoaded(LineType _
As
String) As
Boolean
Dim objLinetype As
AcadLineType
'Hey, same process as LayerExists!
On Error
Resume Next
Set objLinetype = _
ThisDrawing.Linetypes(LineType)
LineTypeLoaded = (Err.Number
= 0)
Err.Clear
Set objLinetype = Nothing
'Return with a value..
End Function
|