教你如何用VB.NET编写AutoCAD中的变色的温度计

这个例子我们去年在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

这是执行效果：

请到我的资源中心下载源代码：

http://barbarahan.download.csdn.net/

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!