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
|