Code:
Public Sub hzInsertBlockMSWithAttributes(ByVal pntInsert As Point3d, _
ByVal strBlockName As String, _
ByVal dScale As Double, _
ByVal strLayerName As String, _
ByVal arrAttrValues As ArrayList, _
ByVal strLayersuffix As String, _
ByVal intLayerfarbe As Integer, _
ByVal Winkel As Double)
Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument
Dim acCurdb As Database = acDoc.Database Try
Using tr As Transaction = acCurdb.TransactionManager.StartTransaction
Dim bt As BlockTable = acCurdb.BlockTableId.GetObject(OpenMode.ForRead)
Dim btrMS As BlockTableRecord = bt(BlockTableRecord.ModelSpace).GetObject(OpenMode.ForRead)
If Not bt.Has(strBlockName) Then
Exit Sub
Else
btrMS.UpgradeOpen()
End If
Dim btr As BlockTableRecord = bt(strBlockName).GetObject(OpenMode.ForWrite)
Dim bref As New BlockReference(pntInsert, btr.ObjectId)
' Wipeout nach unten legen
Dim acObjId As ObjectId
Dim ent As Entity
For Each acObjId In btr
If (acObjId.IsValid) AndAlso (Not acObjId.IsErased) Then
ent = CType(tr.GetObject(acObjId, OpenMode.ForWrite), Entity)
If ent.GetType.ToString = "Autodesk.AutoCAD.DatabaseServices.Wipeout" Then
Dim ids As ObjectIdCollection = New ObjectIdCollection()
btr.DowngradeOpen()
ids.Add(ent.ObjectId)
Dim dot As DrawOrderTable = tr.GetObject(btr.DrawOrderTableId, OpenMode.ForWrite)
dot.MoveToBottom(ids)
End If
End If
Next
'Block drehen
Dim curUCSMatrix As Matrix3d = acDoc.Editor.CurrentUserCoordinateSystem
Dim curUCS As CoordinateSystem3d = curUCSMatrix.CoordinateSystem3d
bref.TransformBy(Matrix3d.Rotation(Winkel, curUCS.Zaxis, pntInsert))
btrMS.AppendEntity(bref)
tr.AddNewlyCreatedDBObject(bref, True)
'Objekt auf Layer setzen und ggfls. neuen Layer erstellen
create_new_layer(strLayerName & strLayersuffix, intLayerfarbe)
' set annotation scale if block is annotative
If btr.Annotative = AnnotativeStates.True Then
Dim ocm As ObjectContextManager = acCurdb.ObjectContextManager
Dim occ As ObjectContextCollection = ocm.GetContextCollection("ACDB_ANNOTATIONSCALES")
Autodesk.AutoCAD.Internal.ObjectContexts.AddContext(bref, occ.CurrentContext)
End If
' Objekt auf Layer setzen
bref.Layer = strLayerName & strLayersuffix
' commit
tr.Commit