Середина между двумя отрезками

> Dimas
Попробуй:

Public Sub MidPt()
Dim Ent1 As AcadEntity
Dim Pt1 As Variant
Dim Ent2 As AcadEntity
Dim Pt2 As Variant
On Error GoTo Err_Control
ThisDrawing.Utility.GetEntity Ent1, Pt1, "Select a first line:"
If Err Then
Err.Clear
Exit Sub
End If
ThisDrawing.Utility.GetEntity Ent2, Pt2, "Select a second line:"
If Err Then
Err.Clear
Exit Sub
End If
Dim mp(2) As Double
mp(0) = (Pt1(0) + Pt2(0)) / 2
mp(1) = (Pt1(1) + Pt2(1)) / 2
mp(2) = (Pt1(2) + Pt2(2)) / 2
ThisDrawing.ModelSpace.AddCircle mp, 10#
Err_Control:
If Err.Number <> 0 Then MsgBox Err.Description
End Sub

~'J'~

По сути заданного вопроса. Не могу добиться точности (чтобы было по средине). То есть селектор чуть в сторону линию выбирает а координаты точек не на линии а чуть в стороне. Как бы snap сделать типа nearest к линии.

getpoint не подойдет потому что если я делаю ось дороги по сьемке то есть две линии края дорожного полотна мне не хочеться расставлять точки по дороге протяженностью 40 км. Но все уже в порядке. Трассирую ось 40 км за пару минут и дорога не слишком радует прямизной. Хотя getpoint я использовал но чуть не так. Надо могу кинуть код.

-----Сначала в проект помещаем класс:
Private vStart As Variant
Private vEnd As Variant
Public Property Let StartPoint(varPnt As Variant)
If IsArray(varPnt) Then
     If UBound(varPnt) = 2 Then
       vStart = varPnt
    End If
  End If
End Property
Public Property Get StartPoint() As Variant
   StartPoint = vStart
End Property
Public Property Let EndPoint(varPnt As Variant)
  If IsArray(varPnt) Then
    If UBound(varPnt) = 2 Then
      vEnd = varPnt
    End If
  End If
End Property
Public Property Get EndPoint() As Variant
  EndPoint = vEnd
End Property
-------Далее модуль:
Public Sub MidPt()
Dim Ent1 As Object
Dim Pt1 As Variant
Dim Ent2 As Object
Dim Pt2 As Variant
Dim mpList() As Double
Dim mp(2) As Double
Dim plineObj As AcadPolyline
Dim objLine As New imaLine
  Dim varSPnt As Variant
  Dim varEPnt As Variant
  Dim strPrmt As String
On Error GoTo Err_Control
LayOld = ThisDrawing.ActiveLayer.Name
nn = 0
99:
ReDim Preserve mpList(nn)
'Выбираем точку на одной линии потом на второй потом далее повторяем сколько надо поперечников
strPrmt = vbCrLf & "Выбери точку: "
  varSPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrmt)
  varEPnt = ThisDrawing.Utility.GetPoint(varSPnt, strPrmt)
  objLine.StartPoint = varSPnt
  objLine.EndPoint = varEPnt
mp(0) = CDbl((objLine.StartPoint(0) + objLine.EndPoint(0)) / 2)
mp(1) = CDbl((objLine.StartPoint(1) + objLine.EndPoint(1)) / 2)
mp(2) = 0
Set objLine = Nothing
mpList(nn) = mp(0)
nn = nn + 1
ReDim Preserve mpList(nn)
mpList(nn) = mp(1)
nn = nn + 1
ReDim Preserve mpList(nn)
mpList(nn) = mp(2)
nn = nn + 1
GoTo 99
Err_Control:
'при клике правой кнопкой мыши или ескейп аварийный выход рисует линию в слой'
Set newlay = ThisDrawing.Layers.Add("Ось дороги")
ThisDrawing.ActiveLayer = newlay
If nn < 5 Then End
ReDim Preserve mpList(nn - 1)
Set plineObj = ThisDrawing.ModelSpace.AddPolyline(mpList)
Set lLl = ThisDrawing.Layers(LayOld)
         ThisDrawing.ActiveLayer = lLl
Set newlay = Nothing
End Sub