教你如何用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/