Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Runtime
Public Class Commands
Private Enum PointPosition As Integer
NA = 0
Inside = 1
Outside = 2
OnCurve = 3
End Enum
Private Shared doc As Document
Private Shared db As Database
Private Shared ed As Editor
Private Shared ucs As Matrix3d
Private Shared pln As Plane
Const minute As Double = 0.00029088820866572 'Угловая минута в радианах
<CommandMethod("POINTRELOBJECT")>
Public Sub PointPositionRelativeToObject()
doc = Core.Application.DocumentManager.MdiActiveDocument
db = doc.Database
ed = doc.Editor
ucs = ed.CurrentUserCoordinateSystem
pln = New Plane(ucs.CoordinateSystem3d.Origin, ucs.CoordinateSystem3d.Zaxis)
Try
Using lockDoc As DocumentLock = doc.LockDocument
Dim crv As Curve = Nothing
Dim pt As Point3d = Nothing
Dim ptPos As PointPosition = PointPosition.NA
Dim crvOpt As New PromptEntityOptions("")
With crvOpt
.AllowNone = True
.AllowObjectOnLockedLayer = True
.Message = vbCrLf & "Выберите объект: "
.SetRejectMessage("Выбранный объект недопустим. ")
.AddAllowedClass(GetType(Circle), False)
.AddAllowedClass(GetType(Ellipse), False)
.AddAllowedClass(GetType(Polyline), False)
End With
Dim crvRes As PromptEntityResult
Do
crvRes = ed.GetEntity(crvOpt)
Select Case crvRes.Status
Case PromptStatus.OK
Using tr As Transaction = db.TransactionManager.StartTransaction
crv = crvRes.ObjectId.GetObject(OpenMode.ForRead)
tr.Commit()
End Using
Exit Do
Case PromptStatus.None
ed.WriteMessage(vbCrLf & "Ничего не выбрано. ")
Continue Do
Case PromptStatus.Cancel
ed.WriteMessage(vbCrLf & "Операция прервана пользователем. ")
Exit Try
Case Else
ed.WriteMessage(vbCrLf & "Непредвиденная ошибка. ")
Exit Try
End Select
Loop
Select Case crv.GetType.Name
Case "Circle", "Ellipse"
'OK
Case "Polyline"
If Not crv.Closed Then
ed.WriteMessage(vbCrLf & "Полилиния должна быть замкнута. ")
Exit Try
End If
If CheckPolylineIntersection(crv.ObjectId) Then
ed.WriteMessage(vbCrLf & "Полилиния не должна самопересекаться. ")
Exit Try
End If
End Select
crv.Highlight()
Dim ptOpt As New PromptPointOptions("")
With ptOpt
.AllowNone = False
.Message = vbCrLf & "Укажите точку: "
End With
Dim ptRes As PromptPointResult = ed.GetPoint(ptOpt)
Select Case ptRes.Status
Case PromptStatus.OK
pt = ptRes.Value
Case PromptStatus.Cancel
ed.WriteMessage(vbCrLf & "Операция прервана пользователем. ")
crv.Unhighlight()
Exit Try
Case Else
ed.WriteMessage(vbCrLf & "Непредвиденная ошибка. ")
crv.Unhighlight()
Exit Try
End Select
Dim cPt As Point3d = crv.GetClosestPointTo(pt, False)
If (pt - cPt).Length <= Tolerance.Global.EqualPoint Then
ptPos = PointPosition.OnCurve
Else
Dim ray As New Ray
With ray
.BasePoint = pt
.SecondPoint = New Point3d(pt.X + 1, pt.Y, 0)
End With
Dim pts1 As New Point3dCollection
crv.IntersectWith(ray, Intersect.OnBothOperands, pln, pts1, IntPtr.Zero, IntPtr.Zero)
Dim rotAxis As Vector3d = pt.GetVectorTo(New Point3d(pt.X, pt.Y, pt.Z + 1))
ray.TransformBy(Matrix3d.Rotation(minute, rotAxis, pt))
Dim pts2 As New Point3dCollection
crv.IntersectWith(ray, Intersect.OnBothOperands, pln, pts2, IntPtr.Zero, IntPtr.Zero)
ray.TransformBy(Matrix3d.Rotation(minute, rotAxis, pt))
Dim pts3 As New Point3dCollection
crv.IntersectWith(ray, Intersect.OnBothOperands, pln, pts3, IntPtr.Zero, IntPtr.Zero)
ray.Dispose()
Dim m = New Integer() {
pts1.Count Mod 2,
pts2.Count Mod 2,
pts3.Count Mod 2
}
Dim av As Integer = Math.Round(m.Average, 0)
If av = 0 Then
ptPos = PointPosition.Outside
Else
ptPos = PointPosition.Inside
End If
End If
Select Case ptPos
Case PointPosition.NA
ed.WriteMessage(vbCrLf & "Не удалось определить местоположение точки относительно объекта. ")
Case PointPosition.Inside
ed.WriteMessage(vbCrLf & "Точка находится внутри контура объекта. ")
Case PointPosition.Outside
ed.WriteMessage(vbCrLf & "Точка находится вне контура объекта. ")
Case PointPosition.OnCurve
ed.WriteMessage(vbCrLf & "Точка находится на контуре объекта. ")
End Select
crv.Unhighlight()
End Using
Catch acadEx As Exception
ed.WriteMessage(vbCrLf & "Во время выполнения произошла ошибка. " & vbCrLf & acadEx.ToString)
Catch sysEx As System.Exception
ed.WriteMessage(vbCrLf & "Во время выполнения произошла ошибка. " & vbCrLf & sysEx.ToString)
End Try
End Sub
End Class