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

Примитивы чертежей AutoCAD (часть 2)

Дуги

Отрисовка дуги по трем точкам

Option Explicit

Sub TEST_ThreePointArc()
  Dim pt1 As Variant, pt2 As Variant, pt3 As Variant
  Dim arcobj As AcadArc

  On Error GoTo ErrTrap:
  pt1 = ThisDrawing.Utility.GetPoint(, "Start Point: ")
  pt2 = ThisDrawing.Utility.GetPoint(, "End Point: ")
  pt3 = ThisDrawing.Utility.GetPoint(, "Bulge Point: ")

  On Error GoTo 0
  Set arcobj = ThreePointArc(pt1, pt2, pt3)

ErrTrap:
  Err.Clear
  On Error GoTo 0
  End
End Sub

Function ThreePointArc(startpt As Variant, endpt As _
Variant, bulgept As Variant) As AcadArc
'NOTE: builds counter-clockwise arcs
  On Error GoTo ErrTrap:

  Dim util As AcadUtility
  Set util = ThisDrawing.Utility

  Dim xa, xb, xc, ya, yb, yc
  xa = endpt(0): ya = endpt(1)
  xb = bulgept(0): yb = bulgept(1)
  xc = startpt(0): yc = startpt(1)

  Dim A As Double, B As Double, C As Double, D As Double
  Dim E As Double, F As Double, G As Double, H As Double
  Dim I As Double, J As Double, x As Double, y As Double

  A = (yc - ya) / 2
  B = (xc - xb) / (yc - yb)
  C = (xb + xc) / 2
  D = (xb - xa) / (ya - yb)
  E = (xa + xb) / 2
  F = (xb - xa) / (ya - yb)
  G = (xc - xb) / (yc - yb)
  H = (ya + yb) / 2
  I = A + B * C + D * E
  J = F + G

  x = I / J
  y = x * D + H - F * E

  Dim center(0 To 2) As Double
  center(0) = x: center(1) = y: center(2) = 0

  Dim startangle As Double, endangle As Double, radius As Double
  radius = Sqr((center(0) - startpt(0)) ^ 2 + (center(1) - _
  startpt(1)) ^ 2)
  startangle = util.AngleFromXAxis(center, startpt)
  endangle = util.AngleFromXAxis(center, endpt)

  Set ThreePointArc = ThisDrawing.ModelSpace.AddArc(center, _
  radius, startangle, endangle)
  On Error GoTo 0
  Exit Function

ErrTrap:
  MsgBox "Error - Points are collinear."
  Err.Clear
  On Error GoTo 0
End Function
 

Отрисовка дуги по трем точкам с отображением резиновой линии

Option Explicit

'///Begins Here:
'///GetPoints is really just a helper, a way of getting
'///The needed points, but it does demonstrate how to use
'///A "Rubber Band" line during selection

Public Sub GetPoints()
  Dim objUtil As AcadUtility
  Dim varPnt1 As Variant
  Dim varPnt2 As Variant
  Dim varPnt3 As Variant
  Dim strPrmt As String
  On Error GoTo Err_Control
  Set objUtil = ThisDrawing.Utility
  strPrmt = vbCr & "First point of arc: "
  varPnt1 = objUtil.GetPoint(Prompt:=strPrmt)
  strPrmt = vbCr & "Second point of arc: "
  'Use bit 32 for rubber band line
  'Запрос точки с отображением резиновой линии
  objUtil.InitializeUserInput 32
  varPnt2 = objUtil.GetPoint(varPnt1, strPrmt)
  strPrmt = vbCr & "End point of arc: "
  objUtil.InitializeUserInput 32
  varPnt3 = objUtil.GetPoint(varPnt2, strPrmt)
  Call ThreePntArc(varPnt1, varPnt2, varPnt3)
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

'@~~~~~~~~~~~~~~~~~~ ThreePntArc ~~~~~~~~~~~~~~~~~~~~~~~@
'@ Pass in the picked points and get back an arc.
'@ This method determines if points are selected
'@ Left to right or vice versa. This is only effective
'@ If the points are picked Start, Next, End
'@ Dependent on the Center_3_pnts Function
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ThreePntArc(vStart, vNext, vEnd) As AcadArc
  'Points are selected
  'Start-Next-End
  Dim objArc As AcadArc
  Dim objUtil As AcadUtility
  Dim objSpace As AcadBlock
  Dim varCenter As Variant
  Dim dblCenter(2) As Double
  Dim dblRad As Double
  Dim dblSang As Double
  Dim dblEang As Double
  Dim blnClockWise As Boolean
  Dim dblBase As Double
  Dim dblBase2 As Double
  Dim strPrmt As String
  On Error GoTo Err_Control
  Set objUtil = ThisDrawing.Utility
  'Need to know direction points where picked in
  dblBase = objUtil.AngleFromXAxis(vStart, vNext)
  dblBase2 = objUtil.AngleFromXAxis(vStart, vEnd)
  If dblBase > dblBase2 Then
    blnClockWise = True
  ElseIf dblBase = dblBase2 Then
    'The user has indicated a line. Add any special
    'handling you want here, but using the Center_3_Pnt
    'Function this will not error (0 slopes are handled)
  End If
  varCenter = Center_3_pnts(vStart, vNext, vEnd)
  dblCenter(0) = varCenter(0)
  dblCenter(1) = varCenter(1)
  'I am leaving the Z of the center point at 0, but you
  'Can set it like..
  If ThisDrawing.ActiveSpace = acModelSpace Then
    Set objSpace = ThisDrawing.ModelSpace
    'This
    'dblCenter(2) = ThisDrawing.ElevationModelSpace
  Else
    Set objSpace = ThisDrawing.PaperSpace
    'Matching in paper space
    'dblCenter(2) = ThisDrawing.ElevationPaperSpace
  End If
  'Or you could use the value of one of the selected points:
  'dblCenter(2) = vStart(2)
  dblRad = Sqr((varCenter(0) - vStart(0)) ^ 2 + _
  (varCenter(1) - vStart(1)) ^ 2)
  dblSang = objUtil.AngleFromXAxis(dblCenter, vStart)
  dblEang = objUtil.AngleFromXAxis(dblCenter, vEnd)
  If blnClockWise Then
    Set objArc = objSpace.AddArc(dblCenter, dblRad, dblEang, _
    dblSang)
  Else
    Set objArc = objSpace.AddArc(dblCenter, dblRad, dblSang, _
    dblEang)
  End If
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function

'@~~~~~~~~~~~~~~~~~~~~~ Center_3_pnts ~~~~~~~~~~~~~~~~~~~~~~~@
'@ Returns the 2 dimensional Center Point of a circle that
'@ Passes through the three points passed to it In the argument
'@ List. Because I didn't use the Z coordinate You can use this
'@ With objects that require 2D points.
'@ No Dependency
'@ Эта функция возвращает точку центра дуги, проходящей через
'@ три заданные точки
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function Center_3_pnts(vPointB, vPointC, _
vPointD) As Variant
  Dim dblTemp As Double
  Dim dblBC As Double
  Dim dblCD As Double
  Dim dblSlope As Double
  Dim dblRad As Double
  Dim dblCenter(1) As Double
  Dim varCenter As Variant
  On Error GoTo Err_Control
  'Make sure we have variant arrays!
  If IsArray(vPointB) And IsArray(vPointC) _
  And IsArray(vPointD) Then
    'Calculate Segment/Perpendicular Bisector
    dblTemp = vPointC(0) * vPointC(0) + vPointC(1) * vPointC(1)
    dblBC = (vPointB(0) * vPointB(0) + vPointB(1) * _
    vPointB(1) - dblTemp) / 2
    dblCD = (dblTemp - vPointD(0) * vPointD(0) - _
    vPointD(1) * vPointD(1)) / 2
    'Slope
    dblSlope = (vPointB(0) - vPointC(0)) * _
    (vPointC(1) - vPointD(1)) - (vPointC(0) - vPointD(0)) * _
    (vPointB(1) - vPointC(1))
    'Special case for 0 slope
    If dblSlope <> 0 Then
      'Invert slope for perpendicular bisector
      dblSlope = 1 / dblSlope
      'center = intersection
      dblCenter(0) = (dblBC * (vPointC(1) - vPointD(1)) - _
      dblCD * (vPointB(1) - vPointC(1))) * dblSlope
      dblCenter(1) = ((vPointB(0) - vPointC(0)) * dblCD - _
      (vPointC(0) - vPointD(0)) * dblBC) * dblSlope
      varCenter = Array(dblCenter(0), dblCenter(1))
    Else
      'The center point is the midpoint, if the slope is 0
      dblCenter(0) = (vPointB(0) + vPointD(0)) / 2
      dblCenter(1) = (vPointB(1) + vPointD(1)) / 2
      varCenter = Array(dblCenter(0), dblCenter(1))
    End If
    Center_3_pnts = varCenter
  End If
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function

 

Полилинии

Отрисовка полилинии

Пример процедуры, отрисовывающей полилинию по точкам, запрашиваемым у пользователя. При вводе точек возможен ввод опций Arc/Close/Length. Если пользователь выбрал опцию Arc, то вновь отрисовываему сегменту будет заданы кривизна (правда, я не понял принцип, по которому задается кривизна дугового сегмента, а именно, принцып задания тангенса ? угла дугового сегмента Bulge). При выборе опции Close полилиния замыкается. Кроме того, вместо ввода точки можно ввести рассояние, и, тогда точка будет расположена на введенном расстоянии от предидущей точки, в направлении, заданным отрезком, соединяющим предидущую точку с точкой полпжения курсора. Для прерываня команды можно нажать клавишу ESC. Для отслеживания нажатия клавиши ESC используется API функция GetAsyncKeyState

Поместите в стандартный модуль следующий код и запустите макрос DrawPline:

Option Explicit

Public Const VK_ESCAPE = &H1B

Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As Long) As Integer

Public Sub DrawPline()
  Dim blnArc As Boolean
  Dim strPrompt As String
  Dim varpnt As Variant
  Dim dblAngl As Double
  Static objPLine As AcadPolyline
  Static dblStrPnt(0 To 2) As Double
  Dim dblRad(0 To 2) As Double
  Static varVertList(0 To 5) As Double
  Dim intNoPnts As Integer
  Dim KeyWords As String
  Dim strUserInput As String
  KeyWords = "Arc Close Line LEngth"
  strPrompt = "Specify Start Point: "
  On Error GoTo ErrControl
  ThisDrawing.Utility.InitializeUserInput 36, KeyWords
  varpnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt)
  strPrompt = "Specify next point or [Arc/Close/LEngth]: "
  Do
  On Error GoTo ErrControl
    If intNoPnts = 0 Then
      varVertList(0) = varpnt(0)
      varVertList(1) = varpnt(1)
      varVertList(2) = varpnt(2)
      intNoPnts = intNoPnts + 1
    ElseIf intNoPnts = 1 Then
      varVertList(3) = varpnt(0)
      varVertList(4) = varpnt(1)
      varVertList(5) = varpnt(2)
      Set objPLine = ThisDrawing.ModelSpace.AddPolyline(varVertList)
      ThisDrawing.Application.Update
      intNoPnts = intNoPnts + 1
    Else
      dblStrPnt(0) = varpnt(0)
      dblStrPnt(1) = varpnt(1)
      dblStrPnt(2) = varpnt(2)
      intNoPnts = intNoPnts + 1
      objPLine.AppendVertex dblStrPnt
    End If
    If blnArc Then
      ' Bulge the vertex (Кривизна сегмента)
      dblAngl = Atn(ThisDrawing.Utility.AngleFromXAxis _
      (objPLine.Coordinate(intNoPnts - 2), varpnt)) * 0.125
      ' Thats not the real value, I just made it up for now.
      ' Честно говоря, я не понял принципа, по которому авторы
      ' задают кривизну дуги. Упомяну толко, что кривизна дугового
      ' сегмента задается параметром Bulge, равным тангенсу 1/4 угла
      ' дуги (Tan(dblAngl/4)). Как задавать эту величину - дело Ваше
      objPLine.SetBulge intNoPnts - 2, dblAngl
    End If
    ThisDrawing.Application.Update
    ThisDrawing.Utility.InitializeUserInput 36, KeyWords
    On Error Resume Next
    varpnt = ThisDrawing.Utility.GetPoint(varpnt, strPrompt)
Select_Here:
    If Err Then
      If Err.Description = "User input is a keyword" Then
        strUserInput = ThisDrawing.Utility.GetInput
        Err.Clear
        If strUserInput = "Arc" Then
          blnArc = True
          strPrompt = "Specify endpoint of arc or [Line/Close]: "
          ThisDrawing.Utility.InitializeUserInput 36, KeyWords
          varpnt = ThisDrawing.Utility.GetPoint(varpnt, strPrompt)
          If Err Then
            GoTo Select_Here
          End If
        ElseIf strUserInput = "Line" Then
          blnArc = False
          strPrompt = "Specify next point or [Arc/Close/LEngth]: "
          ThisDrawing.Utility.InitializeUserInput 36, KeyWords
          varpnt = ThisDrawing.Utility.GetPoint(varpnt, strPrompt)
          If Err Then
            GoTo Select_Here
          End If
        ElseIf strUserInput = "Close" Then
          intNoPnts = intNoPnts + 1
          objPLine.Closed = True
          If blnArc Then
            dblAngl = Atn(ThisDrawing.Utility.AngleFromXAxis _
            (objPLine.Coordinate(intNoPnts - 2), varpnt)) * 0.125
            objPLine.SetBulge intNoPnts - 2, dblAngl
          End If
          GoTo Exit_Here
        End If
      Else
        GoTo ErrControl
      End If
    End If
  Loop
Exit_Here:
  Exit Sub
ErrControl:
  ' В случе возникновения ошибки проверяем,
  ' не нажал ли пользователь ESC
  If CheckKey(VK_ESCAPE) Then
    Resume Exit_Here
  ElseIf Err.Description = "User input is a keyword" Then
    ' Nothing yet!
    Resume Exit_Here
  Else
    MsgBox Err.Description, vbOKOnly, "Llama Control Center"
  End If
End Sub

Function CheckKey(lngKey As Long) As Boolean
  If GetAsyncKeyState(lngKey) Then
    CheckKey = True
  Else
    CheckKey = False
  End If
End Function

 

Отрисовка полилинии с вставкой заданного блока в ее вершинах

Пример процедуры, отрисовывающей полилинию по точкам, запрашиваемым у пользователя. При отрисовке полилинии, кроме того, что отрисовывается собственно полилиния, в ее вершины вставляются блоки с заданым именем. Для опробывания примера поместите в стандартный модуль следующий ниже код. Затем создайте в текущем чертеже чертеже блок с именем "BlkName". Теперь запустите макрос TEST_DrawPlineWsBlock.

Option Explicit

Public Sub DrawPlineWsBlock(strBlkName As String, dblScale As Double,_
dblRot As Double)
  Dim strPrompt As String
  Dim varPnt As Variant
  Static objPLine As AcadPolyline
  Static dblStrPnt(0 To 2) As Double
  Static varVertList(0 To 5) As Double
  Static intNoPnts As Integer
  strPrompt = "Pick The Start Point"
  On Error Resume Next
  Do
    varPnt = Empty
    varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt)
    If IsEmpty(varPnt) Then Exit Do
      If intNoPnts = 0 Then
        varVertList(0) = varPnt(0)
        varVertList(1) = varPnt(1)
        varVertList(2) = varPnt(2)
        ThisDrawing.ModelSpace.InsertBlock varPnt, strBlkName, _
        dblScale, dblScale, dblScale, dblRot
        intNoPnts = intNoPnts + 1
      ElseIf intNoPnts = 1 Then
        strPrompt = "Pick the next point"
        varVertList(3) = varPnt(0)
        varVertList(4) = varPnt(1)
        varVertList(5) = varPnt(2)
        Set objPLine = ThisDrawing.ModelSpace.AddPolyline(varVertList)
        ThisDrawing.ModelSpace.InsertBlock varPnt, strBlkName, _
        dblScale, dblScale, dblScale, dblRot
        ThisDrawing.Application.Update
        intNoPnts = intNoPnts + 1
      Else
        dblStrPnt(0) = varPnt(0)
        dblStrPnt(1) = varPnt(1)
        dblStrPnt(2) = varPnt(2)
        intNoPnts = intNoPnts + 1
        ThisDrawing.ModelSpace.InsertBlock varPnt, strBlkName, _
        dblScale, dblScale, dblScale, dblRot
        objPLine.AppendVertex dblStrPnt
        ThisDrawing.Application.Update
      End If
  Loop While Val(varPnt(0))
End Sub

Public Sub TEST_DrawPlineWsBlock()
  Dim strBlkName As String  ' Имя блока
  Dim dblScale As Double    ' Масштаб вставки блока
  Dim dblRotAng As Double   ' Угол поворота блока
  
  strBlkName = "BlkName"
  dblScale = 1
  dblRotAng = 0
  DrawPline strBlkName, dblScale, dblRotAng
End Sub

 

Определение выбранного пользователем сегмента полилинии

После запуска AddSelectedPoint у пользователя запрашивается полилиния. После указания полилинии к ней добавляется вершина, координаты которой совпадают с точкой указания полилинии. К сожалению функция ThisDrawing.Utility.GetEntity используемая для запроса у пользователя полилинии, и возвращающая точку указания, работает не совсем точно. Точка указания, возвращаемая этой функцией, не находится на указанном объекте, что вызвано тем, что курсор мыши имеет квадратную форму и собственные размеры, а точка указания находится в центре этого курсора. К сожалению разработчики (в версии AutoCAD 2000) не позаботились о том, чтобы функция ThisDrawing.Utility.GetEntit при возвращени точки указания вычисляла координаты точки, лежащей на указанном объекте и ближайшей к точке курсора мыши. Может в более поздних версиях ситуация изменится?

Option Explicit

Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32" _
(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _
ByVal Y2 As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

' Добавление к выбранной полилинии вершины в
' указанной пользователем точке. Вершина добавляется в 
' сегмент, ближайший к указанной точке
Public Sub AddSelectedPoint()
  Dim varPnt As Variant
  Dim objPline As AcadLWPolyline
  Dim varStart As Variant
  Dim varEnd As Variant
  Dim lngRgn As Long
  Dim intVCnt As Integer
  Dim varCords As Variant
  Dim varVert As Variant
  Dim varCord As Variant
  Dim varNext As Variant
  Dim intCrdCnt As Integer
  Dim dblTemp As Double
  Dim intCnt As Integer
  Dim dblVertex(0 To 1) As Double
  On Error GoTo Err_Control
  intCnt = 1
  ThisDrawing.Utility.GetEntity objPline, varPnt
  varCords = objPline.Coordinates
    For Each varVert In varCords
    intVCnt = intVCnt + 1
  Next
  For intCrdCnt = 0 To intVCnt / 2 - 1
    If intCrdCnt < intVCnt / 2 - 1 Then
    varCord = objPline.Coordinate(intCrdCnt)
    varNext = objPline.Coordinate(intCrdCnt + 1)
    lngRgn = CreateRectRgn(CLng(varCord(0)), _
    CLng(varCord(1)), CLng(varNext(0)), CLng(varNext(1)))
    If PtInRegion(lngRgn, CLng(varPnt(0)), CLng(varPnt(1))) <> 0 Then
      dblVertex(0) = varPnt(0)
      dblVertex(1) = varPnt(1)
      objPline.AddVertex intCnt, dblVertex
      Exit For
    End If
    DeleteObject lngRgn
    End If
    intCnt = intCnt + 1
  Next intCrdCnt
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

' Second Function
' This one returns the nearest segment to the picked point:
' Функция возвращает номер сегмента, ближайшего к указанной
' точке
Public Function ReturnSegment() As Integer
  Dim varPnt As Variant
  Dim objPline As AcadLWPolyline
  Dim varStart As Variant
  Dim varEnd As Variant
  Dim lngRgn As Long
  Dim intVCnt As Integer
  Dim varCords As Variant
  Dim varVert As Variant
  Dim varCord As Variant
  Dim varNext As Variant
  Dim intCrdCnt As Integer
  Dim dblTemp As Double
  Dim intCnt As Integer
  On Error GoTo Err_Control
  intCnt = 1
  ThisDrawing.Utility.GetEntity objPline, varPnt
  varCords = objPline.Coordinates
    For Each varVert In varCords
    intVCnt = intVCnt + 1
  Next
  For intCrdCnt = 0 To intVCnt / 2 - 1
    If intCrdCnt < intVCnt / 2 - 1 Then
    varCord = objPline.Coordinate(intCrdCnt)
    varNext = objPline.Coordinate(intCrdCnt + 1)
    lngRgn = CreateRectRgn(CLng(varCord(0)), _
    CLng(varCord(1)), CLng(varNext(0)), CLng(varNext(1)))
    If PtInRegion(lngRgn, CLng(varPnt(0)), CLng(varPnt(1))) <> 0 Then
      ReturnSegment = intCnt
      Exit For
    End If
    DeleteObject lngRgn
    End If
    intCnt = intCnt + 1
  Next intCrdCnt
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function

 

В данном примере при определении номера указанного пользователем сегмента используется API функции CreateRectRgn и PtInRegion. В цыкле перебираются все сегменты полилинии. Через вершины сегментов строится прямоугольный регион, а затем проверяется, находится ли точка внутри полигона. Если точка внутри полигона, то, считается, что сегмент найден. Такой способ очень не точен. взгляните на рисунок с низу. В случае а) все сработает, а вот в случае б) функция может вернуть не верный номер сегмента, здесь все зависит от того, в каком порядке сегменты добавлялись к полилинии. Какой сегмент был создан раньше, тот и будет возвращен. А в случе в) функция вообще не найдет ближайшего сегмента. Также этот метод не сработает в случае с вертикальными или горизонтальными прямолинейными сегментами.

Попробуйте сами решить эту проблему. Я решил ее находя в цикле рассояния от точки, возвращаемой функцией GetEntity до каждого сегмента полилинии по нормали. До какого сегмента расстояние меньше, тот и считается выбранным. Честно говоря, код получился не из изящных, поэтому, хоть я и не заметил ошибок в его работе, здесь я его размещать не буду.

Набор функций для получения свойств сегмента полилинии

Набор приведенных ниже функций позволит определить вид сегмента (Линия, Окружность, Дуга), и, если сегмент является дугой, то можно определить радиус дугового сегмента и координаты его центра.
' Функция, определяющая является ли сегмент перед вершиной
' Vertex полилинии PolyLin дуговым сегментом
Public Function IsArc(PolyLin As AcadLWPolyline, _
Optional Vertex As Integer) As Boolean
  Dim Bulg As Double
  If Vertex = Empty Then Vertex = 0
  Bulg = PolyLin.GetBulge(Vertex)
  If Bulg <> 0 Then IsArc = True
End Function

' Функция, определяющая является ли сегмент перед вершиной
' Vertex полилинии PolyLin окружностью
Public Function IsSemiCircle(PolyLin As AcadLWPolyline, _
Optional Vertex As Integer) As Boolean
  Dim Bulg As Double
  If Vertex = Empty Then Vertex = 0
  Bulg = PolyLin.GetBulge(Vertex)
  If Bulg = 1 Or Bulg = -1 Then IsArc = True
End Function

' Функция принимает значение True, если ли сегмент перед
' вершиной Vertex полилинии PolyLin описан по часовой
' стрелке
Public Function ClockWise(PolyLin As AcadLWPolyline, _
Optional Vertex As Integer) As Boolean
  Dim Bulg As Double
  If Vertex = Empty Then Vertex = 0
  Bulg = PolyLin.GetBulge(Vertex)
  If Bulg < 0 Then ClockWise = True
End Function

' Функция определяющая радиус дугового сегмента полилинии
Public Function Radius(PolyLin As AcadLWPolyline, _
Optional Vertex As Integer) As Double
  Dim PolyPts As Variant
  Dim PolySp(0 To 2) As Double
  Dim PolyEp(0 To 2) As Double
  Dim Lin1 As AcadLine
  Dim Ang As Double
  Dim IsoAng As Double
  Dim Bulg As Double
  If Vertex = Empty Then Vertex = 0
  Bulg = PolyLin.GetBulge(Vertex)
  Ang = Atn(Bulg) * 4
  IsoAng = Ang / 3.141592654 * 180
  If IsoAng < 0 Then
      IsoAng = (IsoAng + 180) / 2
  Else
      IsoAng = (180 - IsoAng) / 2
  End If
  IsoAng = IsoAng / 180 * 3.141592654
  PolyPts = PolyLin.Coordinates
  PolySp(0) = PolyPts(0): PolySp(1) = PolyPts(1)
  PolyEp(0) = PolyPts(2): PolyEp(1) = PolyPts(3)
  Set Lin1 = ThisDrawing.ModelSpace.AddLine(PolySp, PolyEp)
  Radius = (Lin1.Length / 2) / Cos(IsoAng)
  Lin1.Delete
End Function

' Функция определяющая радиус дугового сегмента полилинии
' В отличие от предидущей функции как параметры здесь
' используютсе не Полилиния и Номер сегмента а собственно
' Начальная и Конечнная точки сегмента и параметр, харак-
' терезующий кривизну сегмента полилинии, равный 
' Tg(SAng/4), где SAng - угол дугового сегмента
Public Function BulgeRadius(varSPnt As Variant, _
varEPnt As Variant, dblbulge As Double) As Double
  Dim dblLen As Double
  Dim dblInclAng As Double
  Dim dblRad As Double
  Dim dblAng As Double
  dblLen = Sqr(((varSPnt(0) - varEPnt(0)) ^ 2) + _
  ((varSPnt(1) - varEPnt(1)) ^ 2))
  dblInclAng = Atn(Abs(dblbulge)) * 4
  dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2)
  dblRad = (dblLen / 2) / (Cos(dblAng))
  BulgeRadius = dblRad
End Function

' Функция, возвращающая координаты точки центра дугового
' сегмента полилинии
Public Function CenterPt(PolyLin As AcadLWPolyline, _
Optional Vertex As Integer) As Variant
  Dim PolyPts As Variant
  Dim PolySp(0 To 2) As Double
  Dim PolyEp(0 To 2) As Double
  Dim Lin1 As AcadLine
  Dim Ang As Double
  Dim IsoAng As Double
  Dim Radius As Double
  Dim ClockWise As Boolean
  Dim RadAng As Double
  Dim Bulg As Double
  If Vertex = Empty Then Vertex = 0
  Bulg = PolyLin.GetBulge(Vertex)
  PolyPts = PolyLin.Coordinates
  PolySp(0) = PolyPts(0): PolySp(1) = PolyPts(1)
  PolyEp(0) = PolyPts(2): PolyEp(1) = PolyPts(3)
  Set Lin1 = ThisDrawing.ModelSpace.AddLine(PolySp, PolyEp)
  Ang = Atn(Bulg) * 4
  IsoAng = Ang / 3.141592654 * 180
  If IsoAng < 0 Then
      IsoAng = (IsoAng + 180) / 2
      ClockWise = True
  Else
      IsoAng = (180 - IsoAng) / 2
  End If
  IsoAng = IsoAng / 180 * 3.141592654
  If ClockWise Then
      RadAng = Lin1.Angle + IsoAng + 3.141592654
  Else
      RadAng = Lin1.Angle - IsoAng + 3.141592654
  End If
  Radius = (Lin1.Length / 2) / Cos(IsoAng)
  CenterPt = ThisDrawing.Utility.PolarPoint(PolyEp, RadAng, Radius)
  Lin1.Delete
End Function

' Функция определяющая центр дугового сегмента полилинии
' В отличие от предидущей функции как параметры здесь
' используютсе не Полилиния и Номер сегмента а собственно
' Начальная и Конечнная точки сегмента и параметр, харак-
' терезующий кривизну сегмента полилинии, равный 
' Tg(SAng/4), где SAng - угол дугового сегмента
Public Function BulgeCenterPnt(varSPnt As Variant, _
varEPnt As Variant, dblbulge As Double) As Variant
  Dim dblLen As Double
  Dim dblInclAng As Double
  Dim dblRad As Double
  Dim dblAng As Double
  Dim dblStart(2) As Double
  Dim dblEnd(2) As Double
  Dim varCenter As Variant
  Dim dblBase As Double
  Dim dblMid(2) As Double
  dblStart(0) = varSPnt(0)
  dblStart(1) = varSPnt(1)
  dblEnd(0) = varEPnt(0)
  dblEnd(1) = varEPnt(1)
  'To keep these functions encapsulated I recreated
  'The code you see in the radius function.
  dblLen = Sqr(((varSPnt(0) - varEPnt(0)) ^ 2) + _
  ((varSPnt(1) - varEPnt(1)) ^ 2))
  dblInclAng = Atn(Abs(dblbulge)) * 4
  dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2)
  dblRad = (dblLen / 2) / (Cos(dblAng))
  dblBase = ThisDrawing.Utility.AngleFromXAxis(dblStart, _
  dblEnd)
  If dblbulge > 0 Then
    varCenter = ThisDrawing.Utility.PolarPoint(dblStart, _
    dblBase - dblAng, dblRad)
  Else
    varCenter = ThisDrawing.Utility.PolarPoint(dblStart, _
    dblBase + dblAng, dblRad)
  End If
  BulgeCenterPnt = varCenter
End Function
 

Определение длины полилинии с помощью метода Explode

Представленная ниже функция определяет длину полилинии, не зависимо то того, из каких сегментов состоит эта полилиния (прямолинейных или дуговых), замкнута она или нет. Способ очень оригинальный. Здесь используется метод Explode, разбивающий полилинию на отрезки и дуги, эквивалентные ее сегментам. При этом все полученные таким образом примитивы оказываются в массиве объектов varExploded. Остается только пройтись по членам массива узнавая их длины и суммируя полученные значения, и, не забывая удалять их из чертежа. Все основано на том, чт окоманда Explode и метод Explode работают по разному. Команда удаляет взорваный объект, а метод не удаляет. Для опробывания функции поместите в стандартный модуль следующий код, создайте в чертеже несколько полилиний и запустите процедуру TEST_PolyLength

Option Explicit

' Функция, определяющая длину полилинии
Public Function PolyLength(objPline As AcadLWPolyline) As Double
  Dim intCnt As Integer
  Dim varExploded As Variant
  Dim dblLen As Double
  On Error GoTo Error_Control
  varExploded = objPline.Explode ' Создаем масив примитивов, 
                                 ' эквивалентных сегментам полилинии
  For intCnt = LBound(varExploded) To UBound(varExploded)
  If TypeOf varExploded(intCnt) Is AcadLine Then
  ' Текущий примитив - Отрезок
    dblLen = dblLen + varExploded(intCnt).Length ' Определяем длину
    varExploded(intCnt).Delete ' Удаляем отрезок
  ElseIf TypeOf varExploded(intCnt) Is AcadArc Then
  ' Текущий примитив - Дуга
    dblLen = dblLen + varExploded(intCnt).ArcLength ' Определяем длину
    varExploded(intCnt).Delete ' Удаляем дугу
  End If
  Next intCnt
  PolyLength = dblLen
Exit_Here:
  Exit Function
Error_Control:
  MsgBox Err.Description, Err.Number
  Resume Exit_Here
End Function

Public Sub TEST_PolyLength()
  Dim objGen As Object
  Dim varPnt As Variant
  Dim dblVal As Double
  On Error GoTo Err_Control
  ThisDrawing.Utility.GetEntity objGen, varPnt, "Select a polyline: "
  dblVal = PolyLength(objGen)
  MsgBox dblVal
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 

Определение длины полилинии расчетным путем

Не смотря на то, чт опредидущий способ мне больше по душе, тем не менее, расчетный способ тоже имеет право на существование. Итак:

Option Explicit

Public Function PlineLenEX(objPLine As AcadLWPolyline) As Double
  Dim intVCnt As Integer
  Dim varCords As Variant
  Dim varVert As Variant
  Dim varCord As Variant
  Dim varNext As Variant
  Dim intCrdCnt As Integer
  Dim dblTemp As Double
  Dim dblArc As Double
  Dim dblAng As Double
  Dim dblChord As Double
  Dim dblInclAng As Double
  Dim dblRad As Double

  varCords = objPLine.Coordinates
  For Each varVert In varCords
    intVCnt = intVCnt + 1
  Next
  'For intCrdCnt = 0 To intVCnt / 3 - 1   ' Для AcadPolyline
  '  If intCrdCnt <= intVCnt / 3 - 1 Then ' Для AcadPolyline
  For intCrdCnt = 0 To intVCnt / 2 - 1   ' Для AcadLWPolyline
    If intCrdCnt <= intVCnt / 2 - 1 Then ' Для AcadLWPolyline
      If objPLine.GetBulge(intCrdCnt) = 0 Then
        varCord = objPLine.Coordinate(intCrdCnt)
        'If intCrdCnt < intVCnt / 3 - 1 Then ' Для AcadPolyline
        If intCrdCnt < intVCnt / 2 - 1 Then ' Для AcadLWPolyline
          varNext = objPLine.Coordinate(intCrdCnt + 1)
        Else
          If objPLine.Closed Then
            varNext = objPLine.Coordinate(0)
          Else
            Exit For
          End If
        End If
        'computes a simple Pythagorean length
        ' Для AcadPolyline
        'dblTemp = dblTemp + Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _
        '((varCord(1) - varNext(1)) ^ 2)) ^ 2) + ((varCord(2) - varNext(2)) ^ 2))
        
        ' Для AcadLWPolyline
        dblTemp = dblTemp + Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _
        ((varCord(1) - varNext(1)) ^ 2)) ^ 2))
      Else
        'If there is a bulge we need to get an arc length
        varCord = objPLine.Coordinate(intCrdCnt)
        varNext = objPLine.Coordinate(intCrdCnt + 1)
        ' Для AcadPolyline
        'dblChord = Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _
        '((varCord(1) - varNext(1)) ^ 2)) ^ 2) + ((varCord(2) - varNext(2)) ^ 2))
        
        ' Для AcadLWPolyline
        dblChord = Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _
        ((varCord(1) - varNext(1)) ^ 2)) ^ 2))
        'Bulge is the tangent of 1/4 of the included angle between
        'vertices. So we reverse the process to get the included angle
        dblInclAng = Atn(Abs(objPLine.GetBulge(intCrdCnt))) * 4
        dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2)
        dblRad = (dblChord / 2) / (Cos(dblAng))
        dblArc = dblInclAng * dblRad
        dblTemp = dblTemp + dblArc
      End If
    End If
  Next
  PlineLenEX = dblTemp
End Function

Public Sub TEST_PlineLenEX()
  Dim objPLine As AcadLWPolyline
  Dim varPnt As Variant
  Dim dblPlLenght As Double
  
  On Error GoTo Err_Handler
  ThisDrawing.Utility.GetEntity objPLine, varPnt, "Выберите полилинию"
  dblPlLenght = PlineLenEX(objPLine)
  MsgBox "Длина выбранной полилинии " & CStr(dblPlLenght), _
  vbInformation + vbOKOnly, "TEST_PlineLenEX"
  Exit Sub
Err_Handler:
  MsgBox Err.Description
  Err.Clear
End Sub

 

Реверс точек полилинии (изменеие направления)

Имеется в виду, что первая точка полилинии становится последней, вторая предпоследней и т.д. Если линия замкнутая, то она разравается. Для опробывания функции поместите в стандартный модуль следующий код, создайте в чертеже несколько полилиний и запустите процедуру TEST_ReverseLWPLine

Option Explicit

' Функция, определяющая длину полилинии
Public Function ReverseLWPLine(objPline As AcadLWPolyline) _
As AcadLWPolyline
  Dim objRet As AcadLWPolyline
  Dim intVCnt As Integer
  Dim varCords As Variant
  Dim intDiv As Integer
  Dim dblPnts() As Double
  Dim objSpace As AcadBlock
  Dim intCnt As Integer
  Dim intSegCnt As Integer
  On Error GoTo Err_Control
  'Using this method allows you to reverse PLines in blocks!
  Set objSpace = ThisDrawing.ObjectIdToObject(objPline.OwnerID)
  intDiv = 2
  varCords = objPline.Coordinates
  ReDim dblPnts(UBound(varCords))
  intSegCnt = ((UBound(varCords) - 1) / 2) - 1
  For intVCnt = UBound(varCords) To LBound(varCords) Step -intDiv
    dblPnts(intCnt + 1) = varCords(intVCnt)
    dblPnts(intCnt) = varCords(intVCnt - 1)
    intCnt = intCnt + intDiv
  Next
  Set objRet = objSpace.AddLightWeightPolyline(dblPnts)
  For intCnt = 0 To intSegCnt
    'Get the Bulge from the original and reverse it
    objRet.SetBulge intCnt, -objPline.GetBulge(intSegCnt - intCnt)
  Next intCnt
  objPline.Delete
  Set ReverseLWPLine = objRet
Exit_Here:
  Exit Function
Err_Control:
  Select Case Err.Number
    Case Else
      MsgBox Err.Description
      Err.Clear
      Resume Exit_Here
  End Select
End Function

Public Sub TEST_ReverseLWPLine()
  Dim objGen As Object
  Dim objPline As AcadLWPolyline
  Dim varPnt As Variant

  On Error GoTo Err_Control
  ThisDrawing.Utility.GetEntity objGen, varPnt, "Select a polyline: "
  Set objPline = objGen
  Set objPline = ReverseLWPLine(objPline)
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 

Связь площади полилинии с текстовым объектом

Очень интересный пример. Наводит, так сказать, на размышления. Поместите в модуль "ThisDrawing" текущего чертежа следующий ниже код, создайте в чертеже полилинию и текстовый объект (не Мультитекст, а однострочный текст). Запустите макрос Bind и на заданные запросы выберите сначала полилинию, а затем текст. В результате текстовый объект будет отображать площадь полилинии. Но самое интересное в переди. Измените полилинию. Просто ухватитесь за одну из ее вершин мышью и перенесите ее. Если все зделано правильно, то содержимое текстового объекта автоматически обновиться. Вот тут-то и появляются размышления. А что если вместо обычных переменных использовать массивы? Тогда можно будет связывать между собой несколько объетов чертежа. А что если при редактировании одного объекта обновлять не содержимое текстового объекта, а, например, длину другого объекта, задавая его длину расчитанной по формуле величиной, зависящей от длины редактируемого объекта? А что если при закрытии файла соответствующим образом скидывать в базу данных (в текстовый или ini файл, в реестр, наконец) метки связанных между собой примитивов, а при открытии считывать сохраненные метки, обновляя необходимые связи? Как Вам поле для деятельности? Кто сказал что в AutoCAD нет параметризации? Зделаем ее сами!

Option Explicit

Dim blnEdit As Boolean
Dim WithEvents objPl As AcadLWPolyline
Dim objText As AcadText

Public Sub Bind()
  Dim varPnt As Variant
  Dim objEnt As AcadEntity
  Dim strPrmt As String
  On Error GoTo Err_Control
  strPrmt = vbCr & "Выберите полилинию: "
  Me.Utility.GetEntity objEnt, varPnt, strPrmt
  Set objPl = objEnt
  strPrmt = vbCr & "Выберите текстовый объект: "
  Me.Utility.GetEntity objEnt, varPnt, strPrmt
  Set objText = objEnt
  objText.TextString = objPl.Area
Exit_Here:
  Exit Sub
Err_Control:
  If Err.Description = "Type mismatch" Then
    Resume
  Else
    MsgBox Err.Description
    Resume Exit_Here
  End If
End Sub

Private Sub objPl_Modified(ByVal pObject As AutoCAD.IAcadObject)
  blnEdit = True
End Sub

Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
  On Error GoTo Error_Handler
  If blnEdit Then
    objText.TextString = objPl.Area
    blnEdit = Not blnEdit
  End If
Error_Handler:
End Sub
 

Сохранение координат полилинии в текстовом файле

Очень часто геодезисты спрашивают: "А нельзя ли сохранить координаты вершин указанной полилинии в текстовом или каком другом файле?" Мне даже попадались примеры на AutoLISP, выполняющие эту задачу. Представляю Вашему вниманю вариант решения этой задачи с помощью VBA. Поместите в стандартный модуль следующий код, создайте полилинию и запустите макрос ExportVerts.

Option Explicit

Public Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Public Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Display and use the File open dialog
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ShowOpen() As String
  Dim strTemp As String
  Dim VertName As OPENFILENAME
  VertName.lStructSize = Len(VertName)
  VertName.hwndOwner = ThisDrawing.HWND
  VertName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + _
                         "*.txt" + Chr$(0)
  VertName.lpstrFile = Space$(254)
  VertName.nMaxFile = 255
  VertName.lpstrFileTitle = Space$(254)
  VertName.nMaxFileTitle = 255
  VertName.lpstrInitialDir = CurDir
  VertName.lpstrTitle = "Llamas Are Supreme"
  VertName.flags = 0
  If GetOpenFileName(VertName) Then
    strTemp = (Trim(VertName.lpstrFile))
    ShowOpen = Mid(strTemp, 1, Len(strTemp) - 1)
  End If
End Function

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' The main procedure, if using normal PLines (Z val)
' Read the comments to get the Z coordinate
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Sub ExportVerts()
  Dim intVCnt As Integer
  Dim intFile As Integer
  Dim strFileName As String
  Dim strVert As String
  Dim retCoord As Variant
  Dim plineObj As AcadLWPolyline
  Dim intCnt As Integer
  Dim varVert As Variant
  Dim varPnt As Variant
  Dim varCord As Variant
  Dim intCrdCnt As Integer
  ThisDrawing.Utility.GetEntity plineObj, varPnt, _
  "select the polyline to get vertices from"
  retCoord = plineObj.Coordinates
  intCnt = 1
  intFile = FreeFile
  'This assumes you are opening an existing file!
  strFileName = ShowOpen
  If Not Right(strFileName, 4) = ".txt" Then 
    strFileName = strFileName & ".txt"
  End If
  Open strFileName For Append As intFile
  Print #intFile, " "
  Print #intFile, "       Вершины полилинии:"
  For Each varVert In retCoord
    intVCnt = intVCnt + 1
  Next
  For intCrdCnt = 0 To intVCnt / 2 - 1 'For normal poly 3 - 1
    varCord = plineObj.Coordinate(intCrdCnt)
    strVert = "Вершина " & CStr(intCrdCnt + 1) & " - X=" & _
              CStr(vbdRoundToDecimal(varCord(0), 2))
    strVert = strVert & Space(25 - Len(strVert)) & _
              "Y=" & CStr(vbdRoundToDecimal(varCord(1), 2))
    '@~~~~~~~~~~~~~~~~ POWER CHANGE ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
    ' If using normal Polylines, uncomment the next line
    'strVert = strVert & Space(40 - Len(strVert)) & _
    '         "Z=" & CStr(vbdRoundToDecimal(varCord(2), 2))
    Print #intFile, strVert
  Next
  Close intFile
End Sub

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Round it to any place you need, Jon.
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Private Function vbdRoundToDecimal(dblNumber As Variant, _
intPlace As Integer) As Double
  Dim dblDecimal As Double
  dblDecimal = 10 ^ intPlace
  vbdRoundToDecimal = Int(dblNumber * dblDecimal + 0.05) / dblDecimal
End Function

 

Импорт точек полилинии виз AutoCAD в Excel и экспорт точек из Excel в AutoCAD

Вот еще один пример импорта координат вершин полилинии. На этот раз координаты импортируются из AutoCAD в таблицу Excel.

Создайте новую книгу в MS Excel, перейдите в редактор VBA и выберите пункт меню Tools -> References... В появившемся окне поставьте галочку у пункта AutoCAD 2000 Type Library. Если Вы не находите этого пункта, то нажмите кнопку Browse… и найдите файл acad.tlb. Обычно он находится в корневой папке AutoCAD. Только что мы добавили в проект ссылку на библиотеку AutoCAD, что обеспечит нам доступ ко всем функциям и объектам AutoCAD.Теперь добавьте в стандартный модуль Excel следующий ниже код. Запустите AutoCAD и создайте полилинию. Перейдите к Excel и запустите макрос ImportPoints. При этом AutoCAD активизируется и у Вас запрашивается полилиния. Выберите ее. В текущей таблице в первых двух столбцах появились координаты выбранной Вами полилинии. Теперь сделаем обратную операцию. Вернитесь к AutoCAD и удалите ту полилинию, импорт точек которой Вы только что выполнили. Вернитесь к Excel, выделите те ячейки, в которых содержаться полученные только что координаты и запустите макрос ExportPoints. Перейдите к AutoCAD и Вы увидите, что удаленная полилиния опять на месте.

'***********************ВНИМАНИЕ*************************'
' Следующий ниже код нужно добавить в стандартный модуль '
'                      MS Excel!!!                       '
'*********************************************************

'//////////////////NOTE/////////////////////////////////
' You will need to add a reference to the AutoCAD 2000
' Type Library to run this example book. Use the "Tools -
' References" menu. If you prefere you can switch to late
' binding by changeing the AutoCAD types to generic objects

'//////////////////ПРИМЕЧАНИЕ///////////////////////////////
' Перед использованием представленных в этом блоке процедур
' Вы должны создать в проекте ссылку на библиотеку AutoCAD 2000
' Type Library (файл acad.tlb, обычно он находится в корневой 
' папке AutoCAD). Для этого выберите пункт меню "Tools -
' References в редакторе VBA от MS Excel

Option Explicit

Public Sub ImportPoints()
  Dim objApp As AcadApplication
  Dim objDoc As AcadDocument
  Dim objEnt As AcadEntity
  Dim varPnt As Variant
  Dim strPrmpt As String
  Dim intVCnt As Integer
  Dim varCords As Variant
  Dim varVert As Variant
  Dim varCord As Variant
  Dim varNext As Variant
  Dim intCrdCnt As Integer
  On Error GoTo Err_Control
  Set objApp = GetObject(, "AutoCAD.Application")
  Set objDoc = objApp.ActiveDocument
  AppActivate objApp.Caption
  objDoc.Utility.GetEntity objEnt, varPnt
  If TypeOf objEnt Is AcadLWPolyline Then
    AppActivate Application.Caption
    varCords = objEnt.Coordinates
    For Each varVert In varCords
      intVCnt = intVCnt + 1
    Next
    For intCrdCnt = 0 To intVCnt / 2 - 1
      varCord = objEnt.Coordinate(intCrdCnt)
      Application.Cells(intCrdCnt + 1, 1).Value = varCord(0)
      Application.Cells(intCrdCnt + 1, 2).Value = varCord(1)
    Next intCrdCnt
  Else
    MsgBox "Selected entity was not a LWPolyline"
  End If
Exit_Here:
  If Not objApp Is Nothing Then
    Set objApp = Nothing
    Set objDoc = Nothing
  End If
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

Public Sub ExportPoints()
  Dim vertlist() As Double
  Dim objApp As AcadApplication
  Dim objDoc As AcadDocument
  Dim RowCount As Integer
  Dim strPrmpt As String
  Dim intCnt As Integer
  Dim objCell As Object
  Dim objSheet As Worksheet
  On Error GoTo Err_Control
  Set objSheet = ThisWorkbook.Sheets(1)
  Set objApp = GetObject(, "AutoCAD.Application")
  Set objDoc = objApp.ActiveDocument
  RowCount = objSheet.UsedRange.Rows.Count
  ReDim vertlist((RowCount * 2) - 1)
  RowCount = 1
  For intCnt = LBound(vertlist) To UBound(vertlist) Step 2
    vertlist(intCnt) = objSheet.Cells(RowCount, 1).Value
    vertlist(intCnt + 1) = objSheet.Cells(RowCount, 2).Value
    RowCount = RowCount + 1
  Next
  objDoc.ModelSpace.AddLightWeightPolyline vertlist
  objDoc.Regen acActiveViewport
Exit_Here:
  If Not objApp Is Nothing Then
    Set objApp = Nothing
    Set objDoc = Nothing
  End If
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 

Выделение объектов, находящихся на заданном расстоянии от полилинии

Пример выбора объектов, находящихся на заданном расстоянии от выбранной полилинии. Авторы представленого примера слегка лукавят. На самом деле происходит следующее: Пользователь выбирает полилинии и задает дисстанцию. Процедура выясняет габариты полилинии и выбирает все объекты заданного типа на заданном слое, попадающие в прямоугольное окно, стороны которого больше чем габариты полилинии на заданную пользователем величину. К стати, вместо acSelectionSetWindow (при котором выбираются только те объекты, которые полностью попадают в окно) можно подставить acSelectionSetCrossing (тогда будут выбраны и те объекты, которые не попадают в рамку полностью, но пересекаются ею.). Дла того. чтобы посмотреть как работает этот пример создайте в чертеже полилинию, создайте слой с именем Layer1, создайте несколько текстовых объектов рядом и в отдалении от полилинии и на разных слоях. Поместите код в стандартный модуль и запустите процедуру TEST_SelectTextInDist.

Option Explicit

Public Function SelectTextInDist(strLayerName As String) _
As AcadSelectionSet
  Dim objBound As Variant
  Dim varMin As Variant
  Dim varMax As Variant
  Dim varPnt As Variant
  Dim dblDist As Double
  Dim strPrompt As String
  Dim dblFilPntMin(0 To 2) As Double
  Dim dblFilPntMax(0 To 2) As Double
  Dim intType(0 To 3) As Integer
  Dim varData(0 To 3) As Variant
  Dim objEnt As AcadEntity
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  
  On Error GoTo Err_Control
  
  ' Создаем пустой набор объектов
  Set objSelCol = ThisDrawing.SelectionSets
  
  For Each objSelSet In objSelCol
  ' Проверяем все существующие наборы
    If objSelSet.Name = "textindistance" Then
    ' Если имя любого из существующих набора "trxtindistance"
      ThisDrawing.SelectionSets.Item("textindistance").Delete
    ' Удаляем этот набор во избежании ошибки, т.к. 2 набора
    ' с одинаковыми именами не могут сосуществовать
      Exit For
    End If
  Next
  
  Set objSelSet = ThisDrawing.SelectionSets.Add("textindistance")
  ' Присваеваем вновь созданному набору имя "trxtindistance"
  strPrompt = vbCrLf & "Select entity: "  ' Запрашиваем объект
  ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrompt

  ' Запрашиваем расстояние
  strPrompt = vbCrLf & "Distance around entity to search: "
  dblDist = ThisDrawing.Utility.GetDistance(Prompt:=strPrompt)

  ' Определяем габариты выбранного объекта
  objEnt.GetBoundingBox varMin, varMax

  ' Расчитываем навые координаты для окна выбора
  dblFilPntMin(0) = varMin(0) - dblDist
  dblFilPntMin(1) = varMin(1) - dblDist
  dblFilPntMax(0) = varMax(0) + dblDist
  dblFilPntMax(1) = varMax(1) + dblDist

  ' Обеспечиваем фильтр выбора объектов
  intType(0) = -4
  intType(1) = 0
  intType(2) = 8
  intType(3) = -4
  varData(0) = "<AND"
  varData(1) = "TEXT"
  varData(2) = strLayerName
  varData(3) = "AND>"

  ' Выбираем объекты рамкой с расчитанными габаритами
  objSelSet.Select acSelectionSetWindow, dblFilPntMin, _
  dblFilPntMax, intType, varData
  Set SelectTextInDist = objSelSet

Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function

Public Sub TEST_SelectTextInDist()
  Dim objEnt As AcadText
  Dim TestSet As AcadSelectionSet
  Set TestSet = SelectTextInDist("Layer1")
  For Each objEnt In TestSet
  ' Просматриваем все выбранные объекты
    objEnt.Highlight True  ' и подсвечиваем их
  Next objEnt
End Sub
 



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