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

 

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

 

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

 

' Функция, определяющая является ли сегмент перед вершиной
' 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
 

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

 

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
 

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
 

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

 

'***********************ВНИМАНИЕ*************************'
' Следующий ниже код нужно добавить в стандартный модуль '
'                      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
 

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