Yes i read through that, i suppose the problem is my implementation, so here's the code im using it with:
Imports System
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.EditorInput
<Assembly: CommandClass(GetType(Line_Labler.snibbity))>
Namespace Line_Labler
Public Class snibbity
<CommandMethod("linelabel")>
Public Sub snabble()
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Dim vwtw = Application.GetSystemVariable("viewtwist")
Dim cid As New ObjectIdCollection
Dim meas As Integer = Application.GetSystemVariable("measurement")
Application.SetSystemVariable("textstyle", "MKA Standard")
Dim ansc = Application.GetSystemVariable("cannoscalevalue")
Dim txht As Double
If meas = 0 Then
Application.SetSystemVariable("textsize", 0.125)
Else
Application.SetSystemVariable("textsize", 3.175)
End If
Dim lt As LayerTable
Dim peo As New PromptEntityOptions(vbCrLf & "Select Object AT the Point to be labeled:")
Dim per As PromptEntityResult = ed.GetEntity(peo)
If per.Status = PromptStatus.OK Then
Dim objId As ObjectId = per.ObjectId
Dim dbo As Database = objId.Database
Using tr As Transaction = dbo.TransactionManager.StartTransaction()
lt = DirectCast(tr.GetObject(db.LayerTableId, OpenMode.ForRead), LayerTable)
' First get the currently selected object
' and check whether it's a block reference
Dim br As BlockReference = TryCast(tr.GetObject(objId, OpenMode.ForRead), BlockReference)
If br IsNot Nothing Then
' If so, we check whether the block table record
' to which it refers is actually from an XRef
Dim btrId As ObjectId = br.BlockTableRecord
Dim btr As BlockTableRecord = TryCast(tr.GetObject(btrId, OpenMode.ForRead), BlockTableRecord)
' If so, then we programmatically select the object
' underneath the pick-point already used
Dim pneo As New PromptNestedEntityOptions("")
pneo.NonInteractivePickPoint = per.PickedPoint
pneo.UseNonInteractivePickPoint = True
Dim pner As PromptNestedEntityResult = ed.GetNestedEntity(pneo)
Dim nid As ObjectId = pner.ObjectId
Dim selId As ObjectId = pner.ObjectId
Dim obj As DBObject = tr.GetObject(selId, OpenMode.ForRead)
If pner.Status = PromptStatus.OK Then
If TypeOf obj Is PolylineVertex3d Then 'If nid.ObjectClass = RXClass.GetClass(GetType(PolylineVertex3d)) Then '<---why vertex3d and not straight p3d? need for curve class...
Using tr2 As Transaction = dbo.TransactionManager.StartTransaction()
Dim ent2 As Entity = DirectCast(tr2.GetObject(nid, OpenMode.ForRead), Entity)
nid = ent2.OwnerId
tr2.Commit()
End Using
Using tr2 As Transaction = db.TransactionManager.StartTransaction()
Dim ids As New ObjectIdCollection()
Dim map As New IdMapping
ids.Add(nid)
dbo.WblockCloneObjects(ids, db.CurrentSpaceId, map, DuplicateRecordCloning.Ignore, False)
Dim ent2 As Entity = DirectCast(tr2.GetObject(map(nid).Value, OpenMode.ForWrite), Entity)
ent2.TransformBy(pner.Transform)
ent2.SetPropertiesFrom(br)
If lt.Has("C-VPRT") Then
ent2.LayerId = lt("C-VPRT")
End If
cid.Add(nid)
tr2.Commit()
End Using
GoTo p3d
End If
Dim ent As Entity = DirectCast(obj, Entity)
' Clone the selected object
Dim clob As Object = ent.Clone()
Dim clone As Entity = TryCast(clob, Entity)
If clone IsNot Nothing Then
clone.SetPropertiesFrom(br)
If lt.Has("C-VPRT") Then
clone.LayerId = lt("C-VPRT")
End If
Dim conts As ObjectId() = pner.GetContainers()
For Each contId As ObjectId In conts
Dim cont As BlockReference = TryCast(tr.GetObject(contId, OpenMode.ForRead), BlockReference)
If cont IsNot Nothing Then
clone.TransformBy(cont.BlockTransform)
End If
Next
Dim btr2 As BlockTableRecord = TryCast(tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite), BlockTableRecord)
Dim cloneId As ObjectId = btr2.AppendEntity(clone)
tr.AddNewlyCreatedDBObject(clone, True)
tr.TransactionManager.QueueForGraphicsFlush()
cid.Add(cloneId)
End If
p3d:
per = pner
End If
End If
tr.Commit()
End Using
End If
Using tr As Transaction = db.TransactionManager.StartTransaction
Dim pso As New PromptStringOptions(vbCrLf & "Enter Text:")
pso.AllowSpaces = True
Dim psr As PromptResult = ed.GetString(pso)
Dim inspt As Point3d
Dim rotang As Double
Dim radians As Double
Dim degrees As Double
Dim ent As Entity = tr.GetObject(per.ObjectId, OpenMode.ForRead)
Dim obj As DBObject = tr.GetObject(per.ObjectId, OpenMode.ForRead)
If TypeOf obj Is Curve Then
Dim bah As Curve = TryCast(ent, Curve)
'Calc rotation at point
inspt = bah.GetClosestPointTo(per.PickedPoint, True)
Dim fder As Vector3d = bah.GetFirstDerivative(inspt)
radians = Math.Truncate((Math.Atan2(CDbl(fder.Y), CDbl(fder.X)) + vwtw) * 100000000000) / 100000000000
degrees = Math.Round(radians * (180 / Math.PI), 5)
'check rotation
If degrees = (0 Or 180 Or -180) Then
rotang = 0
Else
rotang = radians
End If
If degrees > 360 Then
rotang = radians - (Math.PI * 2)
degrees = Math.Round(rotang * (180 / Math.PI), 5)
End If
If (degrees > 90 And degrees <= 270) Or (degrees <= -90 And degrees >= -270) Then
rotang = radians + Math.PI
End If
End If
'create mtext, apply rotation at point
Dim bt As BlockTable = tr.GetObject(db.BlockTableId, OpenMode.ForRead)
Dim btr As BlockTableRecord = tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
Dim mt As MText = New MText
mt.Annotative = AnnotativeStates.True
mt.Location = inspt
mt.Attachment = AttachmentPoint.MiddleCenter
mt.Rotation = rotang - vwtw
mt.Contents = String.Concat(psr.StringResult, "\P ")
mt.Height = txht
btr.AppendEntity(mt)
tr.AddNewlyCreatedDBObject(mt, True)
For Each id As ObjectId In cid
Dim ob As DBObject = tr.GetObject(id, OpenMode.ForWrite, True)
ob.Erase()
Next
tr.Commit()
End Using
cid.Clear()
End Sub
End Class
End NamespaceIt fails here, as it still thinks the object is polylinevertex3d, so the insertion point is 0,0:
inspt = bah.GetClosestPointTo(per.PickedPoint, True)
thoughts?