Тема: Координаты поверхности

Как програмно получить координату Z с поверхности имея координаты X Y

Re: Координаты поверхности

> mart-soft
Измени координаты X и Y или добавь
интерактивный ввод этих данных:

Option Explicit
Function PolyCoords(oEnt As AcadEntity) As Variant
' by Fatty T.O.H. () 2007 * all rights removed
' edited 13/8/08
     Dim cnt As Integer
     Dim i As Integer
     Dim j As Integer
     Dim iStep As Integer
     Dim varPt As Variant
     Dim dblCoords() As Double
     Dim dblVert() As Double
     If TypeOf oEnt Is AcadLWPolyline Then
          iStep = 2
     ElseIf TypeOf oEnt Is Acad3DPolyline Or _
            TypeOf oEnt Is AcadPolyline Or _
            TypeOf oEnt Is AcadPolyfaceMesh Or _
            TypeOf oEnt Is AcadPolygonMesh Then
          iStep = 3
     End If
     dblCoords = oEnt.Coordinates
     ReDim ptsArr(0 To (UBound(dblCoords) + 1) \ iStep - 1, 0 To iStep - 1) As Double
     For i = 0 To (UBound(dblCoords) + 1) \ iStep - 1
          For j = 0 To iStep - 1
               ptsArr(i, j) = dblCoords(cnt)
               cnt = cnt + 1
          Next
     Next
     PolyCoords = ptsArr
End Function
Sub SearchForZ()
Dim e As AcadEntity
Dim pt
Dim i As Integer
Dim found As Boolean
ThisDrawing.Utility.GetEntity e, pt, vbCr & "Укажите поверхность"
Dim c As Variant
c = PolyCoords(e)
Dim x As Double
Dim y As Double
x = -120.346495418606 '
y = 419.364229712635 '
Dim z As Double
For i = LBound(c) To UBound(c)
If Abs(c(i, 0) - x) <= 0.00001 Then
If Abs(c(i, 1) - y) <= 0.00001 Then
found = True
z = c(i, 2)
Exit For
End If
End If
Next
If found Then
MsgBox "Координата Z = " & z
Else
MsgBox "Не существует координат с такими X и Y"
End If
End Sub

~'J'~