Imports Autodesk.AutoCAD.ApplicationServices
Imports app = Autodesk.AutoCAD.ApplicationServices.Core.Application
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports gi = Autodesk.AutoCAD.GraphicsInterface
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.Colors
Imports Autodesk.AutoCAD.Geometry
Public Class SegmentHighlight
<CommandMethod("HLIGHTPLINESEGMENT")>
Public Sub HighlightPolylineSegment()
Dim doc As Document = app.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Dim plineId As ObjectId
Dim seg As Integer
Using docLock As DocumentLock = doc.LockDocument
Dim hl As New Highlighting
Do
Dim plineOpt As New PromptEntityOptions("")
With plineOpt
.AllowNone = False
.AllowObjectOnLockedLayer = True
.Message = vbCrLf & "Укажите сегмент полилинии: "
.SetRejectMessage(vbCrLf & "Указанный объект недопустим. ")
.AddAllowedClass(GetType(Polyline), False)
End With
Dim plineRes As PromptEntityResult
plineRes = ed.GetEntity(plineOpt)
Select Case plineRes.Status
Case PromptStatus.OK
plineId = plineRes.ObjectId
Using tr As Transaction = db.TransactionManager.StartTransaction
Dim pline As Polyline = DirectCast(plineRes.ObjectId.GetObject(OpenMode.ForRead), Polyline)
Dim pickPt As Point3d = pline.GetClosestPointTo(plineRes.PickedPoint, True)
Dim param As Double = pline.GetParameterAtPoint(pickPt)
seg = Math.Truncate(param)
tr.Commit()
End Using
If hl.Started Then hl.Stop(True)
Case PromptStatus.Cancel
ed.WriteMessage(vbCrLf & "Операция прервана пользователем. ")
Exit Do
End Select
hl.SetObject(plineId, seg)
hl.Start(True)
Loop
hl.Stop(True)
End Using
End Sub
Public Class Highlighting : Inherits gi.DrawableOverrule
Private _hColor As New EntityColor(255, 204, 51)
Private _originalOverruling As Boolean = False
Private _plineId As ObjectId = ObjectId.Null
Private _started As Boolean
Private _segNum = -1
Public ReadOnly Property Started As Boolean
Get
Return _started
End Get
End Property
Public Sub New()
MyBase.New
End Sub
Public Sub SetObject(plineId As ObjectId, segNum As Integer)
If _started Then Throw New Exception("Выполняется подсветка. Нельзя добавить объект.")
_plineId = plineId
_segNum = segNum
End Sub
Public Sub Start(regen As Boolean)
If _plineId = ObjectId.Null Then Throw New Exception("Отсутствует объект для подсветки.")
_originalOverruling = Overruling
AddOverrule(GetClass(GetType(Polyline)), Me, True)
Overruling = True
_started = True
If regen Then
app.DocumentManager.MdiActiveDocument.Editor.WriteMessage(vbCrLf)
app.DocumentManager.MdiActiveDocument.Editor.Regen()
End If
End Sub
Public Sub [Stop](regen As Boolean)
RemoveOverrule(GetClass(GetType(Polyline)), Me)
Overruling = _originalOverruling
_plineId = ObjectId.Null
_segNum = -1
_started = False
If regen Then
app.DocumentManager.MdiActiveDocument.Editor.WriteMessage(vbCrLf)
app.DocumentManager.MdiActiveDocument.Editor.Regen()
End If
End Sub
Public Overrides Function WorldDraw(drawable As gi.Drawable, wd As gi.WorldDraw) As Boolean
If Not _plineId = ObjectId.Null Then
Dim ent As Entity = TryCast(drawable, Entity)
If Not ent Is Nothing Then
If _plineId = ent.ObjectId Then
Dim pline As Polyline = DirectCast(ent, Polyline)
MyBase.WorldDraw(drawable, wd)
wd.SubEntityTraits.TrueColor = _hColor
wd.Geometry.Polyline(pline, _segNum, 1)
Return True
End If
End If
End If
Return MyBase.WorldDraw(drawable, wd)
End Function
End Class
End Class
