TheSwamp
Code Red => VB(A) => Topic started by: David Hall on March 12, 2008, 01:47:00 PM
-
I did a search and couldn't find any thread on this, so here goes.
Has anyone found a way to use display order without using SendCommand?
-
I found this, so I can go from here
Sub Example_SortentsTable()
' This example creates a SortentsTable object and
' changes the draw order.
' Set drawing to display lineweights and create a True Color object
Dim ACADPref As AcadDatabasePreferences
Set ACADPref = ThisDrawing.Preferences
ACADPref.LineWeightDisplay = True
Dim MyColorObjOne As AcadAcCmColor
Set MyColorObjOne = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.17")
Call MyColorObjOne.SetRGB(80, 100, 244)
' Draw a polyline
Dim plineObj As AcadPolyline
Dim points(0 To 8) As Double
points(0) = 4: points(1) = 4: points(2) = 0
points(3) = 3: points(4) = 5: points(5) = 0
points(6) = 6: points(7) = 20: points(8) = 0
Set plineObj = ThisDrawing.ModelSpace.AddPolyline(points)
plineObj.Lineweight = acLnWt211
Call MyColorObjOne.SetRGB(90, 110, 150)
plineObj.TrueColor = MyColorObjOne
' Draw a line
Dim lineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
startPoint(0) = 5: startPoint(1) = 13: startPoint(2) = 0
endPoint(0) = 5: endPoint(1) = 27: endPoint(2) = 0
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
lineObj.Lineweight = acLnWt211
Call MyColorObjOne.SetRGB(50, 80, 230)
lineObj.TrueColor = MyColorObjOne
' Draw a circle
Dim circleObj As AcadCircle
Dim centerPoint(0 To 2) As Double
Dim radius As Double
centerPoint(0) = 10: centerPoint(1) = 15: centerPoint(2) = 0#
radius = 5#
Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)
circleObj.Lineweight = acLnWt211
Call MyColorObjOne.SetRGB(60, 200, 220)
circleObj.TrueColor = MyColorObjOne
ZoomAll
AcadApplication.Update
'Gxet an extension dictionary and, if necessary, add a SortentsTable object
Dim eDictionary As Object
Set eDictionary = ThisDrawing.ModelSpace.GetExtensionDictionary
' Prevent failed GetObject calls from throwing an exception
On Error Resume Next
Dim sentityObj As Object
Set sentityObj = eDictionary.GetObject("ACAD_SORTENTS")
On Error GoTo 0
If sentityObj Is Nothing Then
' No SortentsTable object, so add one
Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
End If
Dim ObjIds(2) As Long
ObjIds(0) = plineObj.ObjectID
ObjIds(1) = lineObj.ObjectID
ObjIds(2) = circleObj.ObjectID
Dim varObject As AcadObject
Set varObject = ThisDrawing.ObjectIdToObject(ObjIds(2))
Dim arr(0) As AcadObject
Set arr(0) = varObject
'Move the circle object to the bottom
sentityObj.MoveToBottom arr
AcadApplication.Update
End Sub
-
Here is the final result to send Hatchs to Back
Option Explicit
Sub HatchBack()
Dim n As Integer
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim objSelSet As AcadSelectionSet
gpCode(0) = 0
dataValue(0) = "HATCH"
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "DISPLAYORDER" Then
ThisDrawing.SelectionSets("DISPLAYORDER").Delete
End If
Next n
End If
Set objSelSet = ThisDrawing.SelectionSets.Add("DISPLAYORDER")
objSelSet.Select acSelectionSetAll, , , gpCode, dataValue
'Gxet an extension dictionary and, if necessary, add a SortentsTable object
Dim eDictionary As Object
Set eDictionary = ThisDrawing.ModelSpace.GetExtensionDictionary
' Prevent failed GetObject calls from throwing an exception
On Error Resume Next
Dim sentityObj As Object
Set sentityObj = eDictionary.GetObject("ACAD_SORTENTS")
On Error GoTo 0
If sentityObj Is Nothing Then
' No SortentsTable object, so add one
Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
End If
Dim ObjIds(0) As Long
Dim varObject As AcadObject
Dim arr(0) As AcadObject
Dim obj As Object
For Each obj In objSelSet
ObjIds(0) = obj.ObjectID
Set varObject = ThisDrawing.ObjectIdToObject(ObjIds(0))
Set arr(0) = varObject
sentityObj.MoveToBottom arr
Next
AcadApplication.Update
ThisDrawing.SelectionSets.Item("DISPLAYORDER").Delete
End Sub
-
Hi David,
Might I make one two suggestions?
Since the SortEntity object's MoveTo* methods accept an array, build the complete array first and call the method just once instead of at every object.
Dim arr() As AcadObject
ReDim arr(0 To objSelSet.Count - 1)
Dim obj As Object
n = 0
For Each obj In objSelSet
Set arr(n) = obj
n = n + 1
Next
sentityObj.MoveToBottom arr
Not that it would make that much difference in execution speed, but with a lot of hatches it may. Plus, as this would add them to the dictionary in one chunk, I do think it makes a difference in actual display computation time.
Oh, and you will notice I removed the ObjectIdtoObject code. You already have the object in the SS, no reason to get the ObjectID and convert that back to the same object.
-
good idea. I have never used this method before today, so I appreciate the input.