Controlling DRAWORDER by VBA
Using V9.3.13 Pro.
I'm creating a block by VBA containing many Hatches, and insert it in Modelspace.
Using attached routine, I send the blockref to the background. That works ok.
I run the same macro, create an other block with hatches and insert it in Modelspace.
Attached routine is called again to send the new blockref to the background. That works BUT....
the previously inserted blockref pops to the front!
I played with various settings for SORTENTS, HPDRAWORDER and DRAWORDERCTL but none seems to influence this behaviour.
Anyone who can give me clue on this one?
TIA,
Arno van Eeuwen
Public Sub SetDrawOrderToBack(entity As AcadEntity, SendToBack As Boolean)
Dim sortentsTable As AcadSortentsTable
Dim cadObjects(0) As AcadObject
Dim MsBlock As AcadBlock
Dim MsDictionary As AcadDictionary
Set MsBlock = ThisDrawing.Modelspace
Set MsDictionary = MsBlock.GetExtensionDictionary
On Local Error Resume Next
Call MsDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
On Local Error GoTo 0
Set sortentsTable = MsDictionary.GetObject("ACAD_SORTENTS")
Set cadObjects(0) = ThisDrawing.ObjectIdToObject(entity.ObjectID)
If SendToBack Then
Call sortentsTable.MoveToBottom(cadObjects)
Else
Call sortentsTable.MoveToTop(cadObjects)
End If
ThisDrawing.Application.Update
Set sortentsTable = Nothing
Set MsDictionary = Nothing
Set MsBlock = Nothing
Erase cadObjects
End Sub
Comments
-
Small modification to previous example solved the problem:
First try to GET the Dictionary, and in case that fails: ADD the dictionary.
Arno van Eeuwen
Public Sub SetDrawOrderToBack(entity As AcadEntity, SendToBack As Boolean)
Dim sortentsTable As AcadSortentsTable
Dim cadObjects(0) As AcadObject
Dim MsBlock As AcadBlock
Dim MsDictionary As AcadDictionary
Set MsBlock = ThisDrawing.Modelspace
Set MsDictionary = MsBlock.GetExtensionDictionary
On Local Error Resume Next
Set sortentsTable = MsDictionary.GetObject("ACAD_SORTENTS")
On Local Error GoTo 0
If sortentsTable Is Nothing Then
Set sortentsTable = MsDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
End If
Set cadObjects(0) = ThisDrawing.ObjectIdToObject(entity.ObjectID)
If SendToBack Then
Call sortentsTable.MoveToBottom(cadObjects)
Else
Call sortentsTable.MoveToTop(cadObjects)
End If
ThisDrawing.Application.Update
Set sortentsTable = Nothing
Set MsDictionary = Nothing
Set MsBlock = Nothing
Erase cadObjects
End Sub0