Логотип сайта поддержки пользователей САПРО сайте поддержки пользователей САПР Translate to:

Отрисовка типовых элементов

Спецзаки и обозначения

Маркировка центров окружностей и дуг


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 
 

Создание выносной линии для указанного Мультитекста

Перед запуском TwoPointWithSelect создайте в текущем чертеже объект "Многострочный текст" ("Мультитекст"). После запуска процедуры выберите в ответ на первый вопрос созданный Вами Мультитекст, а в ответ на второй вопрос укажите точку, из которой будет начинаться вносная линия. А выносная линия, между прочим, будет "привязана" к текстовому объекту.

Public Sub TwoPointWithSelect()
 Dim intPass As Integer
 Dim dblPnts(0 To 5) As Double
 Dim objLeader As AcadLeader
 Dim objUtil As AcadUtility
 Dim varPnt As Variant
 Dim objNote As AcadMText
 Dim strPrompt As String
 Dim varMin As Variant
 Dim varmax As Variant
 On Error GoTo ErrControl
 Set objUtil = ThisDrawing.Utility
 With objUtil
   strPrompt = vbCrLf & "Pick annotation object: "
   ThisDrawing.Utility.GetEntity objNote, varPnt, strPrompt
   objNote.GetBoundingBox varMin, varmax
   dblPnts(3) = varMin(0)
   dblPnts(4) = varMin(1)
   dblPnts(5) = varMin(2)
   strPrompt = vbCrLf & "Point for leader arrow: "
   .InitializeUserInput 32
   varPnt = .GetPoint(varMin, strPrompt)
   dblPnts(0) = varPnt(0)
   dblPnts(1) = varPnt(1)
 End With
 If ThisDrawing.ActiveSpace = acModelSpace Then
   Set objLeader = ThisDrawing.ModelSpace.AddLeader(dblPnts, _
   objNote, acLineWithArrow)
 Else
   Set objLeader = ThisDrawing.PaperSpace.AddLeader(dblPnts, _
   objNote, acLineWithArrow)
 End If
 Exit Sub
 ErrControl:
 If Err.Description = "User input is a keyword" Then
   Err.Clear
   Exit Sub
 Else
   MsgBox Err.Description
 End If
End Sub
 



Copyright © Сайт поддержки пользователей САПР by Victor Tkachenko