这个例子我们去年在DevDays培训中介绍AutoCAD 2010 API的时候演示过，现在我把关键的代码贴上来。AutoCAD.NET API不支持自定义实体，但是有个叫overrule的技术，对于想用.net来实现自定义实体的用户来说，这个例子是个入门教程。
#Region "HelperClass"
'Global helper class (singleton). Contains central definitions of some global constants,and a few helper functions
Public Class HelperClass
Const mExtDictName As String = "SGP_MyDict" 'Defines Dictionary name for the Extension Dictionary demo
Const mXRecName As String = "SGP_MyDATA" 'Defines Dictionary name for the Extension Dictionary demo
Private Shared mMe As HelperClass
'Name of our dictionary in extension dictionary
Public ReadOnly Property DictionaryName()
Get
Return mExtDictName
End Get
End Property
'Name of our XRecord
Public ReadOnly Property XRecordName()
Return mXRecName
'Protected constructor - to enforce singleton behavior
Protected Sub New()
End Sub
'static function to retrieve one and only instance of singleton
Shared ReadOnly Property GetSingleton()
If mMe Is Nothing Then
mMe = New HelperClass
End If
Return mMe
'Retrieve data (as resbuf) from or Xrecord.
'Returns null object if there's a problem
Public Function GetXRecordData(ByVal obj As DBObject) As ResultBuffer
Dim xRec As Xrecord = Nothing
Dim id As ObjectId = obj.ExtensionDictionary
'Make sure we have an ext dict befoore proceeding
If id.IsValid Then
'Retrieve data using a transaction
Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
Using tr As Transaction = db.TransactionManager.StartTransaction
Dim extDict As DBDictionary = tr.GetObject(id,Autodesk.AutoCAD.DatabaseServices.OpenMode.ForRead,False)
If extDict.Contains(DictionaryName) Then
'We're assuming that if my dictionary exists,then so will the XRecord in it.
Dim dictId As ObjectId = extDict.GetAt(DictionaryName)
Dim myDict As DBDictionary = tr.GetObject(dictId,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> xRec = tr.GetObject(myDict.GetAt(XRecordName),'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> End Using
If xRec Is Nothing Then
Return Nothing
Else
Return xRec.Data
End Function
'Modifies data in our XRecord.
'(creates ou rdictionary and XRecoird if it doesn't already exist)
Public Sub SetXRecordData(ByVal obj As DBObject,ByVal myData As ResultBuffer)
Dim myDict As DBDictionary
Dim xRec As Xrecord = Nothing
If id = ObjectId.Null Then
obj.CreateExtensionDictionary()
id = obj.ExtensionDictionary
End If
myDict = tr.GetObject(dictId,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> myDict = New DBDictionary
extDict.SetAt(DictionaryName,myDict)
tr.AddNewlyCreatedDBObject(myDict,True)
If myDict.Contains(XRecordName) Then
xRec = New Xrecord
myDict.SetAt(XRecordName,xRec)
tr.AddNewlyCreatedDBObject(xRec,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> xRec.Data = myData
tr.Commit()
End Class
#End Region
"Simple Grip Overrule"
'Grip overrule to add our custom grips to the line
Class MyGripOverrule
Inherits GripOverrule
'Our custom grip class
'(Could have derived one class for each grip,but we'll use member dara (Ordinal property) to distinguis grips instead)
Public Class MyGrip
Inherits GripData
Private mGripNum As Integer
Public Property Ordinal() As Integer
Return mGripNum
Set(ByVal value As Integer)
mGripNum = value
End Set
'Call this to tell the grip to move itself
Public Sub Move(ByVal vec As Vector3d)
GripPoint = GripPoint + vec
'Grip draws itself
Public Overrides Function ViewportDraw(ByVal worldDraw As Autodesk.AutoCAD.GraphicsInterface.ViewportDraw,ByVal entityId As Autodesk.AutoCAD.DatabaseServices.ObjectId,ByVal type As Autodesk.AutoCAD.DatabaseServices.GripData.DrawType,ByVal imageGripPoint As Autodesk.AutoCAD.Geometry.Point3d?,ByVal gripSizeInPixels As Integer) As Boolean
Dim unit As Point2d = worldDraw.Viewport.GetNumPixelsInUnitSquare(GripPoint)
worldDraw.Geometry.Circle(GripPoint,1.5 * gripSizeInPixels / unit.X,worldDraw.Viewport.ViewDirection)
Return True
End Function
End Class
'Array to hold our 3 grips
Dim mGripData(2) As GripData
Public Overrides Sub GetGripPoints(ByVal entity As Autodesk.AutoCAD.DatabaseServices.Entity,ByVal grips As Autodesk.AutoCAD.DatabaseServices.GripDataCollection,ByVal curViewUnitSize As Double,ByVal gripSize As Integer,ByVal curViewDir As Autodesk.AutoCAD.Geometry.Vector3d,ByVal bitFlags As Autodesk.AutoCAD.DatabaseServices.GetGripPointsFlags)
Dim rb As ResultBuffer = HelperClass.GetSingleton.GetXRecordData(entity)
'We assume entity is a line
Dim myLine As Line = entity
'Set grip positions to represent temperatures (we're using Celsius)
'min temperature
Dim temp As Integer = rb.AsArray(1).Value
Dim pos As Double = myLine.StartParam + (temp / 100) * (myLine.EndParam - myLine.StartParam)
Dim pt As Point3d = myLine.GetPointAtParameter(pos)
Dim grip As New MyGrip
grip.Ordinal = 0
grip.GripPoint = pt
mGripData(0) = grip
'max temperature
temp = rb.AsArray(2).Value
pos = myLine.StartParam + (temp / 100) * (myLine.EndParam - myLine.StartParam)
pt = myLine.GetPointAtParameter(pos)
grip = New MyGrip
grip.Ordinal = 1
mGripData(1) = grip
'current temperature
temp = rb.AsArray(3).Value
grip.Ordinal = 2
mGripData(2) = grip
'Add our grips to the list
For Each g As MyGrip In mGripData
grips.Add(g)
Next
'Get the standard line grip points as well
MyBase.GetGripPoints(entity,grips,curViewUnitSize,gripSize,curViewDir,bitFlags)
Public Overrides Sub MoveGripPointsAt(ByVal entity As Autodesk.AutoCAD.DatabaseServices.Entity,ByVal offset As Autodesk.AutoCAD.Geometry.Vector3d,ByVal bitFlags As Autodesk.AutoCAD.DatabaseServices.MoveGripPointsFlags)
'We only take action when we get this call on a database resident entity
'Dragging operation makes shallow clone of line,and setting clomeMeForDragging to false is generally a bad idea.
'(If you do set clone me for dragging to false,then don't call bae class overriden methods).
If entity.Id.IsValid Then
'Cast to a Line so we can access properties
Dim lineDir As Vector3d = (myLine.EndPoint - myLine.StartPoint)
lineDir = lineDir.GetNormal 'Direction of Line
Dim offsetDist As Double = lineDir.DotProduct(offset) 'Component of mouse translation along like
'Iterate through list of all grips being moved
For Each g As GripData In grips
If TypeOf g Is MyGrip Then
Dim grip As MyGrip = g 'Cast to our grip type
'Make sure offset never takes grip beyond either end of line
If offsetDist >= 0 Then
If offsetDist > (myLine.EndPoint - grip.GripPoint).Length Then
offsetDist = (myLine.EndPoint - grip.GripPoint).Length
If -offsetDist > (myLine.StartPoint - grip.GripPoint).Length Then
offsetDist = -(myLine.StartPoint - grip.GripPoint).Length
lineDir = lineDir * offsetDist
'retrieve stored data and edit the changed value
Dim val1 As String = rb.AsArray(0).Value
Dim intVal(2) As Integer
intVal(0) = rb.AsArray(1).Value 'min
intVal(1) = rb.AsArray(2).Value 'max
intVal(2) = rb.AsArray(3).Value 'current
'Tell grip to move itself long the line
grip.Move(lineDir)
'Calculate new temperature from grip position along the line
Dim newParam As Double = myLine.GetParameterAtPoint(grip.GripPoint)
Dim newTemp As Integer = 100 * (newParam - myLine.StartParam) / (myLine.EndParam - myLine.StartParam)
'Don't let min temp value rise above max temp
'And don't let max temp go below min temp
If grip.Ordinal = 0 Then
If newTemp < intVal(1) Then
intVal(0) = newTemp
intVal(0) = intVal(1) - 1
ElseIf grip.Ordinal = 1 Then
If newTemp > intVal(0) Then
intVal(1) = newTemp
intVal(1) = intVal(0) + 1
intVal(2) = newTemp
'Create new resbuf with new data and put back in Xrecord
Dim newRb As ResultBuffer = New ResultBuffer(New TypedValue(DxfCode.Text,val1),_
New TypedValue(DxfCode.Int32,intVal(0)),intVal(1)),intVal(2)))
HelperClass.GetSingleton.SetXRecordData(myLine,newRb)
Next
'Remove our grips from the list befroe calling base class function
'(Doesn't seem to like my grips)
For i As Integer = grips.Count - 1 To 0 Step -1
If TypeOf grips(i) Is MyGrip Then
grips.Remove(grips(i))
'If any grips left,then we call base class function
If grips.Count > 0 Then
MyBase.MoveGripPointsAt(entity,offset,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> "Simple DrawableOverrule "
'This overrule adds our custom graphhics to the Line
'We're going to turn our Line into a Thermometer
Class MyDrawOverrule
Inherits DrawableOverrule
Const mSize As Integer = 30 'Universal scaling constant - so I don't have to edit every calculation if I want the thermometer thicker or thinner
'This is the function that gets called to add/replace an entity's WorldDraw graphics
Public Overrides Function WorldDraw(ByVal drawable As Autodesk.AutoCAD.GraphicsInterface.Drawable,ByVal wd As Autodesk.AutoCAD.GraphicsInterface.WorldDraw) As Boolean
'Is it a line? (It should be)
If Not TypeOf (drawable) Is Line Then Return MyBase.WorldDraw(drawable,wd)
Dim myLine As Line = drawable
Dim pts As New Point3dCollection
'Read Xrecord values to populate prompt defauls
Dim resbuf As ResultBuffer = HelperClass.GetSingleton.GetXRecordData(myLine)
Dim myText As String = resbuf.AsArray(0).Value 'Room name
Dim lowerTemp As Integer = resbuf.AsArray(1).Value 'Min temp
Dim upperTemp As Integer = resbuf.AsArray(2).Value 'max temp
Dim curTemp As Integer = resbuf.AsArray(3).Value 'Current temp
Dim curPos As Double = curTemp / 100
Dim perpVec As Vector3d = (myLine.EndPoint - myLine.StartPoint).CrossProduct(myLine.Normal).GetNormal
Dim startParam As Double = myLine.GetParameterAtPoint(myLine.StartPoint)
Dim endParam As Double = myLine.GetParameterAtPoint(myLine.EndPoint)
Dim oldColIndex = wd.SubEntityTraits.Color
Dim oldFillType As FillType = wd.SubEntityTraits.FillType
Dim posParam As Double
Dim gsMarker As IntPtr
'Draw thermometer body
wd.SubEntityTraits.FillType = FillType.FillNever
'right body edge
pts.Clear()
pts.Add(myLine.StartPoint + perpVec * myLine.Length * 2.5 / mSize)
pts.Add(myLine.EndPoint + perpVec * myLine.Length * 2.5 / mSize)
gsMarker = 1
wd.Geometry.Polyline(pts,myLine.Normal,gsMarker)
'left body edge
pts.Clear()
pts.Add(myLine.EndPoint - perpVec * myLine.Length * 2.5 / mSize)
pts.Add(myLine.StartPoint - perpVec * myLine.Length * 2.5 / mSize)
gsMarker = 2
'top body edge
wd.Geometry.CircularArc(myLine.EndPoint - perpVec * myLine.Length * 2.5 / mSize,myLine.EndPoint + (myLine.EndPoint - myLine.StartPoint) * 2.5 / mSize,myLine.EndPoint + perpVec * myLine.Length * 2.5 / mSize,ArcType.ArcSimple)
'bottom body edge
Dim theta As Double = Math.PI / 6
Dim rad As Double = (myLine.Length * 2.5 / mSize) / Math.Sin(theta)
Dim a As Double = (myLine.Length * 2.5 / mSize) / Math.Tan(theta)
Dim bowlCenter As Point3d = myLine.StartPoint + (myLine.StartPoint - myLine.EndPoint).GetNormal * a
wd.Geometry.CircularArc(myLine.StartPoint + perpVec * myLine.Length * 2.5 / mSize,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> myLine.StartPoint + (myLine.StartPoint - myLine.EndPoint).GetNormal * (rad + a),'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> myLine.StartPoint - perpVec * myLine.Length * 2.5 / mSize,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> ArcType.ArcSimple)
'Draw upper temperature marker (in red)
wd.SubEntityTraits.Color = 1
posParam = startParam + (endParam - startParam) * (upperTemp / 100)
pts.Add(myLine.GetPointAtParameter(posParam) - perpVec * myLine.Length * 3 / mSize)
pts.Add(myLine.GetPointAtParameter(posParam) + perpVec * myLine.Length * 3 / mSize)
gsMarker = 3
wd.Geometry.Text(myLine.GetPointAtParameter(posParam) + perpVec * myLine.Length * 4 / mSize,perpVec,myLine.Length * 1.2 / mSize,1,"Max. Temp = " & upperTemp.ToString)
'Draw lower temperature marker (in blue)
wd.SubEntityTraits.Color = 5
posParam = startParam + (endParam - startParam) * (lowerTemp / 100)
"Min. Temp = " & lowerTemp.ToString)
'Draw current temperature marker in different color depending on position w.r.t. min and max temps
Dim colIndex As Integer
If curTemp <= lowerTemp Then
colIndex = 5 'Blue
ElseIf curTemp >= upperTemp Then
colIndex = 1 'Red
colIndex = 94 'Dark green
'Draw current Temperature marker
wd.SubEntityTraits.Color = colIndex
posParam = startParam + (endParam - startParam) * (curTemp / 100)
gsMarker = 4
'(myLine.GetPointAtParameter(posParam),myLine.Length / mSize,myLine.Normal)
'wd.Geometry.Circle(myLine.GetPointAtParameter(posParam),myLine.Length / 30,myText & " Temp = " & curTemp.ToString)
'We want to draw filled primitives (polygon and circle) to represent the mercury in the thermometer
wd.SubEntityTraits.FillType = FillType.FillAlways
'drawable mercury - line first,then bowl
Dim offset As Vector3d = perpVec * myLine.Length / mSize
Dim pt1 As Point3d = myLine.StartPoint + offset
pts.Add(bowlCenter + offset)
pts.Add(bowlCenter - offset)
pts.Add(myLine.GetPointAtParameter(posParam) - offset)
pts.Add(myLine.GetPointAtParameter(posParam) + offset)
wd.Geometry.Polygon(pts)
'mercury bowl
theta = Math.PI / 6
rad = 1.5 * (offset.Length) / Math.Sin(theta)
a = (offset.Length) / Math.Tan(theta)
wd.Geometry.Circle(bowlCenter,rad,myLine.Normal)
'Set old subentitytrait values,then call overriden class worlddraw fn
wd.SubEntityTraits.FillType = oldFillType
wd.SubEntityTraits.Color = oldColIndex
Return MyBase.WorldDraw(drawable,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> "Implementation of the commands"
Class TestOverrule
Implements IExtensionApplication
'Setup some global variables
Shared mDrawOverrule As MyDrawOverrule 'One and only instance of this DrawableOverrule
Shared mGripOverrule As MyGripOverrule 'One and only instance of this TransformOverrule
'Const mExtDictName As String = "SGP_MyDict" 'Defines Dictionary name for the Extension Dictionary demo
'Const mXRecName As String = "SGP_MyDATA" 'Defines Dictionary name for the Extension Dictionary demo
'Called when DLL is loaded by AutoCAD.
Public Sub Initialize() Implements Autodesk.AutoCAD.Runtime.IExtensionApplication.Initialize
'Remind user what the commands are
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
ed.WriteMessage(vbCrLf + "Overrule API example")
ed.WriteMessage(vbCrLf + "Commands are:")
ed.WriteMessage(vbCrLf + "TOGGLEOVERRULE - turns overrule protocol on and off")
ed.WriteMessage(vbCrLf + "ADDDATA - adds extension dictionary to selected line,and filters on Extension dictionary")
'Instantiate our global Overrule and set it to overrule lines with my data attached
mDrawOverrule = New MyDrawOverrule
Overrule.AddOverrule(RXObject.GetClass(GetType(Line)),mDrawOverrule,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> mDrawOverrule.SetExtensionDictionaryEntryFilter(HelperClass.GetSingleton.DictionaryName)
mGripOverrule = New MyGripOverrule
mGripOverrule.SetExtensionDictionaryEntryFilter(HelperClass.GetSingleton.DictionaryName)
'Turn overruling on
Overrule.Overruling = True
'Clean up after ourselves.
Public Sub Terminate() Implements Autodesk.AutoCAD.Runtime.IExtensionApplication.Terminate
Overrule.RemoveOverrule(RXObject.GetClass(GetType(Line)),mDrawOverrule)
mDrawOverrule = Nothing
'Toggles all overrules on and off.
<CommandMethod("TOGGLEOVERRULE")> _
Public Sub ToggleOverrule()
Overrule.Overruling = Not Overrule.Overruling
Application.DocumentManager.MdiActiveDocument.Editor.WriteMessage(vbCrLf & "*** Overrule is now " & Overrule.Overruling.ToString & " ***" & vbCrLf)
Application.DocumentManager.MdiActiveDocument.Editor.Regen()
'Demo of Extension Dictionary filter.
'There's also an Xdata filter,but we won't demonstrate it here - its basically the same).
'This command needs tidying up to use HelperClass functions for XData access. (Currently does its own thing).
<CommandMethod("ADDDATA")> _
Public Sub AddXDictFilter()
'Select a line
Dim opts As New PromptEntityOptions(vbCrLf + "Select a line to add Extension dictionary to:")
opts.SetRejectMessage(vbCrLf + "Sorry dude! That's not a line" + vbCrLf)
opts.AddAllowedClass(GetType(Line),'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> Dim res As PromptEntityResult = ed.GetEntity(opts)
'Only continue if a circle was selected
If res.Status <> PromptStatus.OK Then Exit Sub
'Open circle and make sure it has our dictionary in its extension dictionary
Dim objId As ObjectId = res.ObjectId
Dim db As Database = objId.Database
Dim ent As Entity = tr.GetObject(objId,Autodesk.AutoCAD.DatabaseServices.OpenMode.ForRead)
Dim extId As ObjectId = ent.ExtensionDictionary
'Create ext dict if necessary
If extId = ObjectId.Null Then
ent.UpgradeOpen()
ent.CreateExtensionDictionary()
extId = ent.ExtensionDictionary
'Open ext dict
Dim extDict As DBDictionary = tr.GetObject(extId,Autodesk.AutoCAD.DatabaseServices.OpenMode.ForWrite)
'make sure we clone data when entity is cloned for dragging
extDict.TreatElementsAsHard = True
' If it doesn't contain our dictionary,we add one
Dim temp1Opts As New PromptIntegerOptions(vbCrLf + "Enter Lower Temperature:")
Dim temp2Opts As New PromptIntegerOptions(vbCrLf + "Enter Upper Temperature:")
Dim temp3Opts As New PromptIntegerOptions(vbCrLf + "Enter Current Temperature:")
Dim nameOpts As New PromptStringOptions(vbCrLf + "Enter Name:")
temp1Opts.LowerLimit = 0
temp1Opts.UpperLimit = 100
temp2Opts.LowerLimit = 0
temp2Opts.UpperLimit = 100
temp3Opts.LowerLimit = 0
Dim xRecObjID As ObjectId
Dim xRec As Xrecord
If Not extDict.Contains(HelperClass.GetSingleton.XRecordName) Then
'If dict is not present,then we add it and set up default Xrec to be edited later
extDict.UpgradeOpen()
myDict.TreatElementsAsHard = True
extDict.SetAt(HelperClass.GetSingleton.DictionaryName,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> temp1Opts.DefaultValue = 20
temp2Opts.DefaultValue = 30
temp3Opts.DefaultValue = 25
nameOpts.DefaultValue = "San Rafael"
xRec = New Xrecord()
xRec.Data = New ResultBuffer( _
New TypedValue(DxfCode.Text,nameOpts.DefaultValue),temp1Opts.DefaultValue),temp2Opts.DefaultValue),temp3Opts.DefaultValue))
xRecObjID = myDict.SetAt(HelperClass.GetSingleton.XRecordName,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> Else
'If dict exists,then we extract values from XRecord to populate default values from prompt
Dim dictId As ObjectId = extDict.GetAt(HelperClass.GetSingleton.DictionaryName)
temp1Opts.DefaultValue = 30
xRecObjID = myDict.GetAt(HelperClass.GetSingleton.XRecordName)
xRec = tr.GetObject(xRecObjID,'sans-serif'; mso-fareast-font-family: 新宋体; mso-no-proof: yes"> 'xRec now points to our XRecord,which is open for write.
Dim val1 As TypedValue = xRec.Data.AsArray(0) 'Room name
Dim val2 As TypedValue = xRec.Data.AsArray(1) 'Min temp
Dim val3 As TypedValue = xRec.Data.AsArray(2) 'Max temp
Dim val4 As TypedValue = xRec.Data.AsArray(3) 'Current temp
nameOpts.DefaultValue = val1.Value
temp1Opts.DefaultValue = val2.Value
temp2Opts.DefaultValue = val3.Value
temp3Opts.DefaultValue = val4.Value
'Prompt for new values
Dim nameRes As PromptResult = ed.GetString(nameOpts)
If nameRes.Status = PromptStatus.OK Then
val1 = New TypedValue(DxfCode.Text,nameRes.StringResult)
Dim temp1Res As PromptIntegerResult = ed.GetInteger(temp1Opts)
If temp1Res.Status = PromptStatus.OK Then
val2 = New TypedValue(DxfCode.Int32,temp1Res.Value)
Dim temp2Res As PromptIntegerResult = ed.GetInteger(temp2Opts)
If temp2Res.Status = PromptStatus.OK Then
val3 = New TypedValue(DxfCode.Int32,temp2Res.Value)
Dim temp3Res As PromptIntegerResult = ed.GetInteger(temp3Opts)
If temp3Res.Status = PromptStatus.OK Then
val4 = New TypedValue(DxfCode.Int32,temp3Res.Value)
'Now set Xrecord contents to new values
xRec.Data = New ResultBuffer(val1,val2,val3,val4)
End Using
'Display new results
ed.Regen()
Region
这是执行效果：
请到我的资源中心下载源代码：
原文链接：https://www.f2er.com/vb/261984.html