Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.DatabaseServices.Filters
Public Class cmatMain
Inherits CommonAutoCADVariables
<CommandMethod("MergeVisibleEntities")> Public Sub MergeVisibleEngities()
'step by step
'for each block/xref in selection 'done
'get a collection of visible layers.
'get the entities in the block
'get the clipping boundary of the block 'done
'filter out any entity that is not visible.
'bountry trim the remaining entities inside the boundary
'remove any entities outside of the boundary.
'add remaining entities to new entity layer in model space block
'next block
'commit
Try
Using trans As Transaction = ThisDrawing.TransactionManager.StartTransaction
Dim ssOid() As ObjectId
Dim oids As New ObjectIdCollection
Dim oid As ObjectId
Dim ss As SelectionSet = Nothing
Dim pso As New PromptSelectionOptions
pso.MessageForAdding = "Add Blocks/Xrefs to process: "
pso.MessageForRemoval = "Remove Blocks/Xrefs from processing: "
pso.AllowDuplicates = False
pso.RejectPaperspaceViewport = True
pso.AllowSubSelections = False
Dim psr As PromptSelectionResult = ed.GetSelection(pso)
If psr.Status = PromptStatus.OK Then
ss = psr.Value
ssOid = ss.GetObjectIds
For I As Integer = 0 To ssOid.GetUpperBound(0)
oids.Add(ssOid(I))
Next
For Each oid In oids
Dim ent As Entity = trans.GetObject(oid, OpenMode.ForRead, False, True)
If ent.GetType Is GetType(BlockReference) Then
Dim bref As BlockReference = ent
Dim brDbd As DBDictionary = trans.GetObject(bref.ExtensionDictionary, OpenMode.ForRead, False, True)
For Each item As DBDictionaryEntry In brDbd
Debug.Print(item.ToString)
Dim dbd As DBDictionary = item.Value.GetObject(OpenMode.ForRead)
For Each dbdent As DBDictionaryEntry In dbd
Debug.Print(dbdent.ToString)
'get spacial filter from xref
Dim spf As Filters.SpatialFilter = dbdent.Value.GetObject(OpenMode.ForRead)
'get point collection of boundary points from spacial filter (xclip boundary)
Dim pcol As Point2dCollection = spf.Definition.GetPoints
'create an index to attempt to activate this spacial filter and return filtered entities
Dim indy As New Filters.SpatialIndex
'create a collection pool to store the index data in
Dim indupd As IndexUpdateData = Nothing
'force the index to rebuild with this new pool
''unfortunately this throws the error "object not set.."
indy.RebuildFull(indupd)
'get the iterator in order to cycle through the filtered entities
''unfortunately this throws the error "access to corrupted memory..."
Dim iter As Filters.FilteredBlockIterator = indy.GetIterator(spf)
'this never got to run, but it was supposed to recollect the object IDs so that i could use them.
Dim foids As New ObjectIdCollection
iter.Start()
Do
Dim foid As ObjectId = iter.Next
If foid = Nothing Then Exit Do
foids.Add(foid)
Loop
Next
Next
End If
Next
Else
Exit Sub
End If
End Using
Catch ex As System.Exception
MsgBox(ex.ToString)
Exit Sub
End Try
End Sub
End Class
Thanks,
jvj
It's about time I answer my own question again...
An Xref or block that has a boundary clip creates a collection of points and stores it in its extention dictionary. A rectangular clip stores 2 points (opposite corners) and all other polylines store all the points of the polyline. Over time, I managed to compile all the help info and previous posts from each of you to create a few consice chunks of code I use to determine if an object in code is also an object on screen, or is it clipped out. Here is that code:
Imports Autodesk.AutoCAD.DatabaseServices Imports Autodesk.AutoCAD.Geometry Imports Autodesk.AutoCAD.DatabaseServices.Filters Public Class XClippedBlock Dim mXClipPoints As Point3dCollection = Nothing Public Property BlockRef As BlockReference Public Property XClipped As Boolean = False Public Property XClipBounds As Point2dCollection = Nothing Public Property XClipMatrix As Matrix3d = Nothing Public Property XClipSpatialFilter As SpatialFilter = Nothing Public ReadOnly Property XClipBoundaryPoints As Point3dCollection Get If mXClipPoints = Nothing Then If XClipBounds IsNot Nothing Then If XClipBounds.Count > 0 Then mXClipPoints = New Point3dCollection If XClipBounds.Count = 2 Then Dim p1 As New Point3d(XClipBounds(0).X, XClipBounds(0).Y, 0) Dim p2 As New Point3d(XClipBounds(1).X, XClipBounds(0).Y, 0) Dim p3 As New Point3d(XClipBounds(1).X, XClipBounds(1).Y, 0) Dim p4 As New Point3d(XClipBounds(0).X, XClipBounds(1).Y, 0) mXClipPoints.Add(p1) mXClipPoints.Add(p2) mXClipPoints.Add(p3) mXClipPoints.Add(p4) Else For Each Point2d In XClipBounds mXClipPoints.Add(New Point3d(Point2d.X, Point2d.Y, 0)) Next End If End If End If End If Return mXClipPoints End Get End Property Private Sub New() 'hide me End Sub Public Sub New(ByRef bref As BlockReference, trans As Transaction) If bref IsNot Nothing Then BlockRef = bref If bref.ExtensionDictionary <> ObjectId.Null Then Dim brDbd As DBDictionary = trans.GetObject(bref.ExtensionDictionary, OpenMode.ForRead, False, True) For Each item As DBDictionaryEntry In brDbd If item.ToString.Contains("ACAD_FILTER") Then Dim dbd As DBDictionary = item.Value.GetObject(OpenMode.ForRead) For Each dbdent As DBDictionaryEntry In dbd If dbdent.ToString.Contains("SPATIAL") Then 'get spacial filter from xref XClipSpatialFilter = dbdent.Value.GetObject(OpenMode.ForRead) ''get point collection of boundary points from spacial filter (xclip boundary) XClipped = XClipSpatialFilter.Definition.Enabled If XClipped Then XClipBounds = XClipSpatialFilter.Definition.GetPoints ''create an index to attempt to activate this spacial filter and return filtered entities XClipMatrix = XClipSpatialFilter.ClipSpaceToWorldCoordinateSystemTransform End If End If Next End If Next End If End Sub Public Sub IntersectsWith(ByRef ent As Entity, ByRef pts As Point3dCollection, ByRef trans As Transaction) If XClipped Then 'verify if the object in question is even withing the clipped bounds If XClipSpatialFilter.ClipVolumeIntersectsExtents(ent.GeometricExtents) Then 'explode the blockref, and cycle through the entities Using trans2 As Transaction = trans.TransactionManager.StartTransaction Dim objs As DBObjectCollection = New DBObjectCollection() BlockRef.Explode(objs) For Each obj As DBObject In objs 'verify if each enitity is within the clipped bounds Dim brefpts As New Point3dCollection Dim entBref As Entity = CType(obj, Entity) If XClipSpatialFilter.ClipVolumeIntersectsExtents(entBref.GeometricExtents) Then IntersectionPtsForEntities(entBref, ent, brefpts, trans2) If brefpts.Count > 0 Then 'qualify these points inside the xclip bounds For Each pnt As Point3d In brefpts Dim pExtents As New Extents3d(pnt, pnt) If XClipSpatialFilter.ClipVolumeIntersectsExtents(pExtents) Then If Not pts.Contains(pnt) Then pts.Add(pnt) End If Next End If End If Next For Each obj In objs obj.Dispose() Next trans2.Commit() End Using End If Else Using trans2 As Transaction = trans.TransactionManager.StartTransaction Dim objs As DBObjectCollection = New DBObjectCollection() BlockRef.Explode(objs) For Each obj As DBObject In objs Dim entBref As Entity = CType(obj, Entity) IntersectionPtsForEntities(entBref, ent, pts, trans2) Next For Each obj In objs obj.Dispose() Next trans2.Commit() End Using End If End Sub Public Function ExplodeBlockRef(ByRef trans As Transaction) As List(Of Entity) Dim finalList As New List(Of Entity) Dim eSet As New DBObjectCollection BlockRef.Explode(eSet) For Each obj As DBObject In eSet 'verify if each enitity is within the clipped bounds Dim entFromExplode As Entity = CType(obj, Entity) If TypeOf entFromExplode Is BlockReference Then Dim xcBlockRef As New XClippedBlock(entFromExplode, trans) finalList.AddRange(xcBlockRef.ExplodeBlockRef(trans)) Else If XClipSpatialFilter.ClipVolumeIntersectsExtents(entFromExplode.GeometricExtents) Then 'either add par of the entity or the whole thing... Dim booAddedPart As Boolean = False 'trim the entitiy to the bounds before adding If TypeOf entFromExplode Is Curve Then Dim curv As Curve = entFromExplode 'collect intersection point for all sides Dim boundaryIntersectPoints As New Point3dCollection For i As Integer = 0 To XClipBoundaryPoints.Count - 1 Dim indexStart As Integer = i Dim indexEnd As Integer = i + 1 If i = XClipBoundaryPoints.Count - 1 Then indexEnd = 0 End If Dim lBoundary As New Line(XClipBoundaryPoints(indexStart), XClipBoundaryPoints(indexEnd)) 'add to the intersection points for this side IntersectionPtsForEntities(curv, lBoundary, boundaryIntersectPoints, trans) lBoundary.Dispose() Next 'if anything is found, then with all combined points, split the curve on these points If boundaryIntersectPoints.Count > 0 Then 'note to self sc=SplitCurves Dim scObjColl As DBObjectCollection = Nothing scObjColl = curv.GetSplitCurves(boundaryIntersectPoints) 'if anything was split, then find the objects that remain in the xclipped boundary If scObjColl IsNot Nothing Then For Each scObj As Object In scObjColl If TypeOf scObj Is Entity Then Dim scEnt As Entity = scObj Dim scCurve As Curve = scObj Dim sP As Point3d = scCurve.StartPoint Dim eP As Point3d = scCurve.EndPoint Dim ext As New Extents3d(sP, sP) If XClipSpatialFilter.ClipVolumeIntersectsExtents(ext) Then ext = New Extents3d(eP, eP) If XClipSpatialFilter.ClipVolumeIntersectsExtents(ext) Then 'both points are within the boundary If TypeOf scObj Is Arc Then Dim midPoint As Point3d = FindArcMidpoint(scObj) 'check if object swings inside of boundary by testing it's midpoint ext = New Extents3d(midPoint, midPoint) If XClipSpatialFilter.ClipVolumeIntersectsExtents(ext) Then finalList.Add(scObj) booAddedPart = True End If Else finalList.Add(scObj) booAddedPart = True End If End If End If End If Next End If End If End If If Not booAddedPart Then finalList.Add(entFromExplode) End If End If End If Next Return finalList End Function End Class
The limitations in this code is the breaking of polylines and splines when clipping. So now whenever I run across a block that may be xclipped, I run the block through this object to find it's boundaries and if I have a possible intersection. There may be better ways to rewrite this code or portions of it, so feel free.
jvj
Yea, that was one of my sources as well. Notice he sets the XClip data in the Extention Dictionary. Would be nice if there were a more higher level approach in the API.
jvj