Public Shared Function AppendEntity(ByVal ent As Entity) As ObjectId
Dim db As Database = HostApplicationServices.WorkingDatabase
Dim entId As ObjectId
Using trans As Transaction = db.TransactionManager.StartTransaction
Dim bt As BlockTable = trans.GetObject(db.BlockTableId, OpenMode.ForRead)
Dim btr As BlockTableRecord = trans.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
entId = btr.AppendEntity(ent)
trans.AddNewlyCreatedDBObject(ent, True)
trans.Commit()
End Using
Return entId
End Function
Public Shared Function AddRectangle(ByVal cenPt As Point3d, ByVal Height As Double, _
ByVal Length As Double, ByVal Name As String, ByVal Size As String) As ObjectId
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim db As Database = HostApplicationServices.WorkingDatabase
Using trans As Transaction = db.TransactionManager.StartTransaction
Dim Xrec As New Xrecord()
Xrec.Data = New ResultBuffer( _
New TypedValue(DxfCode.Text, Size), _
New TypedValue(DxfCode.Text, Name))
'Define the rectangle
Dim Pt(4) As Point3d
Pt(0) = New Point3d(cenPt.X - Length * 0.5, cenPt.Y - Height * 0.5, 0)
Pt(1) = New Point3d(cenPt.X + Length * 0.5, cenPt.Y - Height * 0.5, 0)
Pt(2) = New Point3d(cenPt.X + Length * 0.5, cenPt.Y + Height * 0.5, 0)
Pt(3) = New Point3d(cenPt.X - Length * 0.5, cenPt.Y + Height * 0.5, 0)
Pt(4) = New Point3d(cenPt.X - Length * 0.5, cenPt.Y - Height * 0.5, 0)
Dim Pts As New Point3dCollection(Pt)
Dim ent As New Polyline3d(Poly3dType.SimplePoly, Pts, False)
'Add the rectangle polyline entity to model space
Dim EntId As ObjectId = AppendEntity(ent)
ent.CreateExtensionDictionary()
EntId = ent.ExtensionDictionary()
Dim entXrecord As DBDictionary = trans.GetObject(EntId, OpenMode.ForWrite)
entXrecord.SetAt("MyXrecode", Xrec)
trans.AddNewlyCreatedDBObject(Xrec, True)
Return EntId
trans.Commit()
End Using
End Function
Private RectIds As ObjectIdCollection = New ObjectIdCollection() 'Hold the ObjectId for later use
<CommandMethod("DrawRectXRecord")> _
Public Sub InsertRectWithXRecord()
'' Get the current database and start the Transaction Manager
Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument
Dim acCurDb As Database = acDoc.Database
Dim acEd As Editor = acDoc.Editor
Dim pPtRes As PromptPointResult
Dim pPtOpts As PromptPointOptions = New PromptPointOptions("")
pPtOpts.Message = vbLf & "Click to insert "
pPtRes = acDoc.Editor.GetPoint(pPtOpts)
Dim ptStart As Point3d = pPtRes.Value
'' Exit if the user presses ESC or cancels the command
If pPtRes.Status = PromptStatus.Cancel Then Exit Sub
'' Start a transaction
Using Trans As Transaction = acCurDb.TransactionManager.StartTransaction()
'Draw the Rectangle
Dim RectId As ObjectId = AddRectangle(ptStart, 1000, 2000, "RectWithXRecord", "1000X2000")
RectIds.Add(RectId)
acEd.WriteMessage(vbCrLf + RectId.ToString()) 'I can get the ObjectId showed on the command line panel
Trans.Commit()
End Using
End Sub
Public Shared Function AddRectangle(ByVal cenPt As Point3d, ByVal Height As Double, _
ByVal Length As Double, ByVal Name As String, ByVal Size As String) As ObjectId
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim db As Database = HostApplicationServices.WorkingDatabase
'the objectId will be retured
Dim retVal As ObjectId = ObjectId.Null()
Using trans As Transaction = db.TransactionManager.StartTransaction
'Define the rectangle
Dim Pt(4) As Point3d
Pt(0) = New Point3d(cenPt.X - Length * 0.5, cenPt.Y - Height * 0.5, 0)
Pt(1) = New Point3d(cenPt.X + Length * 0.5, cenPt.Y - Height * 0.5, 0)
Pt(2) = New Point3d(cenPt.X + Length * 0.5, cenPt.Y + Height * 0.5, 0)
Pt(3) = New Point3d(cenPt.X - Length * 0.5, cenPt.Y + Height * 0.5, 0)
Pt(4) = New Point3d(cenPt.X - Length * 0.5, cenPt.Y - Height * 0.5, 0)
Dim Pts As New Point3dCollection(Pt)
' 在内存中创建一个未经拟合的标准三维多段线对象.
Dim ent As New Polyline3d(Poly3dType.SimplePoly, Pts, True)
Dim btr As BlockTableRecord = trans.GetObject(db.CurrentSpaceId, OpenMode.ForWrite)
retVal = btr.AppendEntity(ent)
trans.AddNewlyCreatedDBObject(ent, True)
'新建一个扩展记录对象
'Add the extension dictionary and xrecord to the polyline
Dim Xrec As New Xrecord()
Xrec.Data = New ResultBuffer( _
New TypedValue(DxfCode.Text, Size), _
New TypedValue(DxfCode.Text, Name))
ent.CreateExtensionDictionary()
Dim xDict As DBDictionary = trans.GetObject(ent.ExtensionDictionary, OpenMode.ForWrite)
xDict.SetAt("MyXrecods", Xrec)
trans.AddNewlyCreatedDBObject(Xrec, True)
trans.Commit()
End Using
Return retVal
End Function
Private RectIds As ObjectIdCollection = New ObjectIdCollection()
<CommandMethod("DrawRectXRecord")> _
Public Sub InsertRectWithXRecord()
'' Get the current database and start the Transaction Manager
Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument
Dim acCurDb As Database = acDoc.Database
Dim acEd As Editor = acDoc.Editor
Dim pPtRes As PromptPointResult
Dim pPtOpts As PromptPointOptions = New PromptPointOptions("")
pPtOpts.Message = vbLf & "Click to insert "
pPtRes = acDoc.Editor.GetPoint(pPtOpts)
Dim ptStart As Point3d = pPtRes.Value
'' Exit if the user presses ESC or cancels the command
If pPtRes.Status = PromptStatus.Cancel Then Exit Sub
'绘制矩形
'Draw the Rectangle
Dim RectId As ObjectId = AddRectangle(ptStart, 1000, 2000, "RectWithXRecord", "1000X2000")
RectIds.Add(RectId)
acEd.WriteMessage(vbCrLf + RectId.ToString()) 'I can get the ObjectId showed on the command line panel
End Sub
<CommandMethod("ListRectXRecord")> _
Public Sub ListRectWithXrecord()
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim db As Database = HostApplicationServices.WorkingDatabase
Using trans As Transaction = db.TransactionManager.StartTransaction
' 遍历选择集.
For Each sSetEntId As ObjectId In RectIds
Dim ent As Entity = trans.GetObject(sSetEntId, OpenMode.ForRead)
'ed.WriteMessage((vbCrLf & "您选择的是: " & ent.GetType().Name))
'打开所选择对象的扩展字典
Dim entXrecord As DBDictionary = trans.GetObject(ent.ExtensionDictionary, OpenMode.ForRead)
'在扩展字典中搜索关键字为MyXrecord的扩展记录对象,如果找到则返回它的ObjectId
Dim xrecordId As ObjectId = entXrecord.GetAt("MyXrecods")
'打开找到的扩展记录对象
Dim xrecord As Xrecord = trans.GetObject(xrecordId, OpenMode.ForRead)
'获取扩展记录中包含的数据列表并循环遍历显示它们
Dim rb As ResultBuffer = xrecord.Data
For Each value As TypedValue In rb
ed.WriteMessage(String.Format(vbCrLf & "TypeCode={0},Value={1}", value.TypeCode, value.Value))
Next
Next sSetEntId
'Dim ent As Entity = trans.GetObject(res.ObjectId, OpenMode.ForRead)
trans.Commit()
End Using
End Sub