教你如何用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()
Get
Return mXRecName
End Get
End Property

'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()
Get
If mMe Is Nothing Then
mMe = New HelperClass
End If
Return mMe
End Get
End Property

'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, Autodesk.AutoCAD.DatabaseServices.OpenMode.ForRead, False)
xRec = tr.GetObject(myDict.GetAt(XRecordName), Autodesk.AutoCAD.DatabaseServices.OpenMode.ForRead, False)
End If
End Using
End If
If xRec Is Nothing Then
Return Nothing
Else
Return xRec.Data
End If
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 db As Database = Application.DocumentManager.MdiActiveDocument.Database
Using tr As Transaction = db.TransactionManager.StartTransaction

Dim myDict As DBDictionary
Dim xRec As Xrecord = Nothing

Dim id As ObjectId = obj.ExtensionDictionary

If id = ObjectId.Null Then
obj.CreateExtensionDictionary()
id = obj.ExtensionDictionary
End If


Dim extDict As DBDictionary = tr.GetObject(id, Autodesk.AutoCAD.DatabaseServices.OpenMode.ForWrite, False)

If extDict.Contains(DictionaryName) Then
Dim dictId As ObjectId = extDict.GetAt(DictionaryName)
myDict = tr.GetObject(dictId, Autodesk.AutoCAD.DatabaseServices.OpenMode.ForWrite, False)
Else
myDict = New DBDictionary
extDict.SetAt(DictionaryName, myDict)
tr.AddNewlyCreatedDBObject(myDict, True)
End If


If myDict.Contains(XRecordName) Then
xRec = tr.GetObject(myDict.GetAt(XRecordName), Autodesk.AutoCAD.DatabaseServices.OpenMode.ForWrite, False)
Else
xRec = New Xrecord
myDict.SetAt(XRecordName, xRec)
tr.AddNewlyCreatedDBObject(xRec, True)
End If

xRec.Data = myData
tr.Commit()
End Using
End Sub
End Class


#End Region



#Region "Simple Grip Overrule"


'Grip overrule to add our custom grips to the line
Public 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
Get
Return mGripNum
End Get
Set(ByVal value As Integer)
mGripNum = value
End Set
End Property

'Call this to tell the grip to move itself
Public Sub Move(ByVal vec As Vector3d)
GripPoint = GripPoint + vec
End Sub

'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
grip.GripPoint = pt
mGripData(1) = grip

'current temperature
temp = rb.AsArray(3).Value
pos = myLine.StartParam + (temp / 100) * (myLine.EndParam - myLine.StartParam)
pt = myLine.GetPointAtParameter(pos)
grip = New MyGrip
grip.Ordinal = 2
grip.GripPoint = pt
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)

End Sub



Public Overrides Sub MoveGripPointsAt(ByVal entity As Autodesk.AutoCAD.DatabaseServices.Entity, ByVal grips As Autodesk.AutoCAD.DatabaseServices.GripDataCollection, 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 myLine As Line = entity

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
End If
Else
If -offsetDist > (myLine.StartPoint - grip.GripPoint).Length Then
offsetDist = -(myLine.StartPoint - grip.GripPoint).Length
End If
End If
lineDir = lineDir * offsetDist

'retrieve stored data and edit the changed value
Dim rb As ResultBuffer = HelperClass.GetSingleton.GetXRecordData(entity)
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
Else
intVal(0) = intVal(1) - 1
End If
ElseIf grip.Ordinal = 1 Then
If newTemp > intVal(0) Then
intVal(1) = newTemp
Else
intVal(1) = intVal(0) + 1
End If
Else
intVal(2) = newTemp
End If

'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)), _
New TypedValue(DxfCode.Int32, intVal(1)), _
New TypedValue(DxfCode.Int32, intVal(2)))
HelperClass.GetSingleton.SetXRecordData(myLine, newRb)
End If
Next
End If

'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))
End If
Next
'If any grips left, then we call base class function
If grips.Count > 0 Then
MyBase.MoveGripPointsAt(entity, grips, offset, bitFlags)
End If

End Sub



End Class


#End Region




#Region "Simple DrawableOverrule "

'This overrule adds our custom graphhics to the Line
'We're going to turn our Line into a Thermometer
Public 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
wd.Geometry.Polyline(pts, myLine.Normal, gsMarker)

'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, _
myLine.StartPoint + (myLine.StartPoint - myLine.EndPoint).GetNormal * (rad + a), _
myLine.StartPoint - perpVec * myLine.Length * 2.5 / mSize, _
ArcType.ArcSimple)

'Draw upper temperature marker (in red)
wd.SubEntityTraits.Color = 1
posParam = startParam + (endParam - startParam) * (upperTemp / 100)
pts.Clear()
pts.Add(myLine.GetPointAtParameter(posParam) - perpVec * myLine.Length * 3 / mSize)
pts.Add(myLine.GetPointAtParameter(posParam) + perpVec * myLine.Length * 3 / mSize)
gsMarker = 3
wd.Geometry.Polyline(pts, myLine.Normal, gsMarker)

wd.Geometry.Text(myLine.GetPointAtParameter(posParam) + perpVec * myLine.Length * 4 / mSize, myLine.Normal, perpVec, myLine.Length * 1.2 / mSize, 1, 0, "Max. Temp = " & upperTemp.ToString)

'Draw lower temperature marker (in blue)
wd.SubEntityTraits.Color = 5
posParam = startParam + (endParam - startParam) * (lowerTemp / 100)
pts.Clear()
pts.Add(myLine.GetPointAtParameter(posParam) - perpVec * myLine.Length * 3 / mSize)
pts.Add(myLine.GetPointAtParameter(posParam) + perpVec * myLine.Length * 3 / mSize)
gsMarker = 3
wd.Geometry.Polyline(pts, myLine.Normal, gsMarker)
wd.Geometry.Text(myLine.GetPointAtParameter(posParam) + perpVec * myLine.Length * 4 / mSize, myLine.Normal, perpVec, myLine.Length * 1.2 / mSize, 1, 0, "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
Else
colIndex = 94 'Dark green
End If

'Draw current Temperature marker
wd.SubEntityTraits.Color = colIndex

posParam = startParam + (endParam - startParam) * (curTemp / 100)
pts.Clear()
pts.Add(myLine.GetPointAtParameter(posParam) - perpVec * myLine.Length * 3 / mSize)
pts.Add(myLine.GetPointAtParameter(posParam) + perpVec * myLine.Length * 3 / mSize)
gsMarker = 4
wd.Geometry.Polyline(pts, myLine.Normal, gsMarker) '(myLine.GetPointAtParameter(posParam), myLine.Length / mSize, myLine.Normal)
'wd.Geometry.Circle(myLine.GetPointAtParameter(posParam), myLine.Length / 30, myLine.Normal)
wd.Geometry.Text(myLine.GetPointAtParameter(posParam) + perpVec * myLine.Length * 4 / mSize, myLine.Normal, perpVec, myLine.Length * 1.2 / mSize, 1, 0, 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
pts.Clear()
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, wd)



End Function


End Class

#End Region




#Region "Implementation of the commands"



Public 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, False)
mDrawOverrule.SetExtensionDictionaryEntryFilter(HelperClass.GetSingleton.DictionaryName)

'Instantiate our global Overrule and set it to overrule lines with my data attached
mGripOverrule = New MyGripOverrule
Overrule.AddOverrule(RXObject.GetClass(GetType(Line)), mGripOverrule, False)
mGripOverrule.SetExtensionDictionaryEntryFilter(HelperClass.GetSingleton.DictionaryName)

'Turn overruling on
Overrule.Overruling = True

End Sub

'Clean up after ourselves.
Public Sub Terminate() Implements Autodesk.AutoCAD.Runtime.IExtensionApplication.Terminate
Overrule.RemoveOverrule(RXObject.GetClass(GetType(Line)), mDrawOverrule)
mDrawOverrule = Nothing
Overrule.RemoveOverrule(RXObject.GetClass(GetType(Line)), mGripOverrule)
mDrawOverrule = Nothing
End Sub


'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()
End Sub



'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 ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
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), True)
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

Using tr As Transaction = db.TransactionManager.StartTransaction

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
End If

'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
temp1Opts.UpperLimit = 100


Dim xRecObjID As ObjectId
Dim xRec As Xrecord
Dim myDict As DBDictionary
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 = New DBDictionary
'make sure we clone data when entity is cloned for dragging
myDict.TreatElementsAsHard = True

extDict.SetAt(HelperClass.GetSingleton.DictionaryName, myDict)
tr.AddNewlyCreatedDBObject(myDict, True)
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), _
New TypedValue(DxfCode.Int32, temp1Opts.DefaultValue), _
New TypedValue(DxfCode.Int32, temp2Opts.DefaultValue), _
New TypedValue(DxfCode.Int32, temp3Opts.DefaultValue))
xRecObjID = myDict.SetAt(HelperClass.GetSingleton.XRecordName, xRec)
tr.AddNewlyCreatedDBObject(xRec, True)

Else
'If dict exists, then we extract values from XRecord to populate default values from prompt
'We're assuming that if my dictionary exists, then so will the XRecord in it.
Dim dictId As ObjectId = extDict.GetAt(HelperClass.GetSingleton.DictionaryName)
myDict = tr.GetObject(dictId, Autodesk.AutoCAD.DatabaseServices.OpenMode.ForWrite, False)
temp1Opts.DefaultValue = 20
temp1Opts.DefaultValue = 30
xRecObjID = myDict.GetAt(HelperClass.GetSingleton.XRecordName)
xRec = tr.GetObject(xRecObjID, Autodesk.AutoCAD.DatabaseServices.OpenMode.ForRead, False)

End If
'xRec now points to our XRecord, which is open for write.

'Read Xrecord values to populate prompt defauls
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)
End If

Dim temp1Res As PromptIntegerResult = ed.GetInteger(temp1Opts)
If temp1Res.Status = PromptStatus.OK Then
val2 = New TypedValue(DxfCode.Int32, temp1Res.Value)
End If

Dim temp2Res As PromptIntegerResult = ed.GetInteger(temp2Opts)
If temp2Res.Status = PromptStatus.OK Then
val3 = New TypedValue(DxfCode.Int32, temp2Res.Value)
End If

Dim temp3Res As PromptIntegerResult = ed.GetInteger(temp3Opts)
If temp3Res.Status = PromptStatus.OK Then
val4 = New TypedValue(DxfCode.Int32, temp3Res.Value)
End If

'Now set Xrecord contents to new values
xRec.Data = New ResultBuffer(val1, val2, val3, val4)


tr.Commit()

End Using

'Display new results
ed.Regen()

End Sub
End Class

#End Region

这是执行效果：





请到我的资源中心下载源代码：
http://barbarahan.download.csdn.net/