[evgm]

привет всем
помогите с кодом VBA - что-то не могу сообразить...
в SelectionSet имеем несколько выбранных пользователем точек
через GetPoint и GetAngle пользователь указывает линию проекции
нужно вычислить расстояние между проекциями этих точек на эту линию.
Заранее спасибо!

[fixo]

Почти то что тебе нужно, за исключением только
что линия должна быть нарисована, потом ее можно
удалить
Измени эту часть под свои нужды

Код:

[Выделить все]

Option Explicit

'' based on code written by Tony Tanzillo
'' request check "Break on Unhandled Errors" in  General options

Public Sub Profiling()
Dim ptColl As Collection
Set ptColl = New Collection
Dim intOsm As Integer
intOsm = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 35
Dim Msg As String
Msg = vbCrLf & "First point: "
Dim MyPoint As Variant

Do
On Error Resume Next
MyPoint = ThisDrawing.Utility.GetPoint(, Msg)
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0

ptColl.Add MyPoint
Msg = vbCrLf & "Next point or ENTER to exit: "
Loop
On Error GoTo 0

Dim oEntity As AcadEntity
Dim varPt As Variant
ThisDrawing.Utility.GetEntity oEntity, varPt, vbCr & "Select a projection line >> "
If Not oEntity Is Nothing Then
If TypeOf oEntity Is AcadLine Then
Dim oLine As AcadLine
Set oLine = oEntity
Dim stPt As Variant, endPt As Variant
stPt = oLine.StartPoint: endPt = oLine.EndPoint
End If
End If

Dim pi As Double
pi = Atn(1#) * 4
Dim ang As Double
ang = ThisDrawing.Utility.AngleFromXAxis(stPt, endPt)
Dim outColl As Collection
Set outColl = New Collection
Dim itm

For Each itm In ptColl
Dim tmpPt1(2) As Double
tmpPt1(0) = itm(0): tmpPt1(1) = itm(1): tmpPt1(2) = itm(2):
Dim tmp As Variant
tmp = ThisDrawing.Utility.PolarPoint(tmpPt1, ang - pi / 2, 1)
Dim tmpPt2(2) As Double
tmpPt2(0) = tmp(0): tmpPt2(1) = tmp(1): tmpPt2(2) = tmp(2):
Dim oXLine As AcadXline
Set oXLine = ThisDrawing.ModelSpace.AddXline(tmpPt1, tmpPt2)
Dim intPt As Variant
intPt = oXLine.IntersectWith(oLine, acExtendThisEntity)
outColl.Add intPt
oXLine.Delete
Next itm

Dim i As Integer
Dim dblDist As Double
ReDim distArr(0 To outColl.Count - 2)
For i = 1 To outColl.Count - 1
dblDist = Get_Distance(outColl.Item(i), outColl.Item(i + 1))
distArr(i - 1) = dblDist
Next i
ThisDrawing.SetVariable "OSMODE", intOsm

End Sub

'//------------------------------------------------------------//'

Public Function Get_Distance(fPoint As Variant, sPoint As Variant) As Double

     Dim x1 As Double, x2 As Double
     Dim y1 As Double, y2 As Double
     Dim z1 As Double, z2 As Double
     Dim cDist As Double

     x1 = fPoint(0): y1 = fPoint(1): z1 = fPoint(2)
     x2 = sPoint(0): y2 = sPoint(1): z2 = sPoint(2)

     cDist = Sqr(((x2 - x1) ^ 2) + ((y2 - y1) ^ 2) + ((z2 - z1) ^ 2))
     Get_Distance = cDist

End Function

~'J'~

[evgm]

огромное спасибо
щас попробую разобраться.