显示命令
**** Hidden Message ***** 我发现了这个，所以我可以从这里开始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
下面是将Hatchs发送到Back的最终结果代码1] 好主意。 在今天之前，我从未使用过这种方法，因此我很感激您的输入。
页:
[1]